1716 lines
79 KiB
Scheme
1716 lines
79 KiB
Scheme
"cptypes.ss"
|
|
;;; cptypes.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.
|
|
|
|
#|
|
|
Notes:
|
|
- (cptypes ir ctxt types) -> (values ir ret types t-types f-types)
|
|
+ arguments
|
|
ir: expression to be optimized
|
|
ctxt: 'effect 'test 'value
|
|
types: an immutable dictionary (currently an intmap).
|
|
The dictionary connects the counter of a prelex with the types
|
|
discovered previously.
|
|
(fxmap ([prelex-counter x] . 'pair)
|
|
([prelex-counter y] . 'vector)
|
|
([prelex-counter z] . `(quote 0)))
|
|
plxc: an opaque object that must be passed around (it is actually
|
|
a (mutable) box with a counter for numbering the prelex)
|
|
+ results
|
|
ir: the optimized expression
|
|
ret: type of the result of the expression
|
|
types: like the types in the argument, with the addition of the types
|
|
discover during the optimization of the expression
|
|
t-types: types to be used in case the expression is not #f, to be used in
|
|
the "then" branch of an if.
|
|
This is usually only filled in a text context.
|
|
It may be #f, and in this case the `if` clause will use the value
|
|
of types as a replacement.
|
|
(Also the clauses for `let[rec/*]` handle the #f case specialy.)
|
|
f-types: idem for the "else" branch. (if x (something) <here x is #f>)
|
|
|
|
|
|
- predicate: They may be:
|
|
* a symbol to indicate the type, like 'vector 'pair 'number
|
|
(there are a few fake values, in particular 'bottom is used to
|
|
signal that there is an error)
|
|
* a nanopass-quoted value that is okay-to-copy?, like
|
|
`(quote 0) `(quote 5) `(quote #t) `(quote '())
|
|
(this doesn't includes `(quote <record-type-descriptor>))
|
|
* a record #[pred-$record/rtd <rtd>] to signal that it's a
|
|
record of type <rtd>
|
|
* a record #[pred-$record/ref <ref>] to signal that it's a
|
|
record of a type that is stored in the variable <ref>
|
|
(these may collide with other records)
|
|
* TODO?: add something to indicate that x is a procedure to
|
|
create/setter/getter/predicate of a record of that type
|
|
|
|
- Primitives are marked as procedures, without distinction.
|
|
- Most of the time I'm using eq? and eqv? as if they were equivalent.
|
|
I assume that the differences are hidden by unspecified behavior.
|
|
|
|
|#
|
|
|
|
|
|
(define $cptypes)
|
|
(let ()
|
|
(import (nanopass))
|
|
(include "base-lang.ss")
|
|
(include "fxmap.ss")
|
|
|
|
(define (prelex-counter x plxc)
|
|
(or (prelex-operand x)
|
|
(let ([c (unbox plxc)])
|
|
(set-box! plxc (fx+ c 1))
|
|
(prelex-operand-set! x c)
|
|
c)))
|
|
|
|
(with-output-language (Lsrc Expr)
|
|
(define void-rec `(quote ,(void)))
|
|
(define true-rec `(quote #t))
|
|
(define false-rec `(quote #f))
|
|
(define null-rec `(quote ()))
|
|
(define empty-vector-rec `(quote #()))
|
|
(define empty-string-rec `(quote ""))
|
|
(define empty-bytevector-rec `(quote #vu8()))
|
|
(define empty-fxvector-rec `(quote #vfx()))
|
|
(define eof-rec `(quote #!eof))
|
|
(define bwp-rec `(quote #!bwp))
|
|
|
|
(module (simple?) ; Simplified version copied from cp0. TODO: copy the rest.
|
|
(define default-fuel 5)
|
|
(define (simple? e)
|
|
(sp? e default-fuel))
|
|
(define (sp? e fuel)
|
|
(and (fx> fuel 0)
|
|
(let ([fuel (fx- fuel 1)])
|
|
(nanopass-case (Lsrc Expr) e
|
|
[(quote ,d) #t]
|
|
[(if ,e1 ,e2 ,e3)
|
|
; useful to recognize the expansion of `not`
|
|
(and (sp? e1 fuel) (sp? e2 fuel) (sp? e3 fuel))]
|
|
[(ref ,maybe-src ,x) #t]
|
|
[(case-lambda ,preinfo ,cl* ...) #t]
|
|
[,pr #t]
|
|
[(moi) #t]
|
|
[(record-type ,rtd ,e) (sp? e fuel)]
|
|
[else #f]
|
|
#;[else ($oops who "unrecognized record ~s" e)])))))
|
|
|
|
(module (single-valued?)
|
|
(define default-fuel 5)
|
|
(define (single-valued? e)
|
|
(sv? e default-fuel))
|
|
(define (sv? e fuel)
|
|
(and (fx> fuel 0)
|
|
(let ([fuel (fx- fuel 1)])
|
|
(nanopass-case (Lsrc Expr) e
|
|
[(quote ,d) #t]
|
|
[(seq ,e1 ,e2)
|
|
(sv? e fuel)]
|
|
[(if ,e1 ,e2, e3)
|
|
(and (sv? e2 fuel)
|
|
(sv? e3 fuel))]
|
|
[(call ,preinfo ,pr ,e* ...)
|
|
(all-set? (prim-mask single-valued) (primref-flags pr))]
|
|
[(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ; let-like expressions
|
|
(guard (fx= interface (length e*)))
|
|
(sv? body fuel)]
|
|
[(letrec ((,x* ,e*) ...) ,body)
|
|
(sv? body fuel)]
|
|
[(letrec* ((,x* ,e*) ...) ,body)
|
|
(sv? body fuel)]
|
|
[(ref ,maybe-src ,x) #t]
|
|
[(case-lambda ,preinfo ,cl* ...) #t]
|
|
[(set! ,maybe-src ,x ,e) #t]
|
|
[(immutable-list (,e* ...) ,e) #t]
|
|
[,pr #t]
|
|
[(record-cd ,rcd ,rtd-expr ,e) #t]
|
|
[(record-ref ,rtd ,type ,index ,e) #t]
|
|
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
|
|
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t]
|
|
[(record-type ,rtd ,e) #t]
|
|
[(record ,rtd ,rtd-expr ,e* ...) #t]
|
|
[(pariah) #t]
|
|
[(profile ,src) #t]
|
|
[(moi) #t]
|
|
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
|
|
[else #f]))))
|
|
)
|
|
|
|
; Reprocess expression when it is changed from a 'value or 'test context
|
|
; to a 'effect context, in a reduction like (pair? x) => (begin x #t)
|
|
; Assume that cptypes has already analyzed the expression.
|
|
(module (drop)
|
|
(define default-fuel 5)
|
|
(define (drop ir)
|
|
(dr ir default-fuel))
|
|
(define-pass dr : Lsrc (ir fuel) -> Lsrc ()
|
|
(Expr : Expr (ir fuel) -> Expr ()
|
|
[(quote ,d)
|
|
void-rec]
|
|
[(ref ,maybe-src ,x)
|
|
void-rec]
|
|
[(seq ,e1 ,[dr : e2 fuel -> e2])
|
|
(make-seq/no-drop 'effect e1 e2)]
|
|
[(if ,e1 ,[dr : e2 fuel -> e2] ,[dr : e3 fuel -> e3])
|
|
(cond
|
|
[(eq? e2 e3)
|
|
(make-1seq 'effect e1 e2)]
|
|
[else
|
|
`(if ,e1 ,e2 ,e3)])]
|
|
[(case-lambda ,preinfo ,cl* ...)
|
|
void-rec]
|
|
[(call ,preinfo ,pr ,e)
|
|
(guard (eq? (primref-name pr) '$value))
|
|
(cond
|
|
[(single-valued? e)
|
|
(make-seq 'effect e void-rec)]
|
|
[else ir])]
|
|
[(call ,preinfo ,pr ,e* ...)
|
|
(let ([flags (primref-flags pr)])
|
|
(cond
|
|
[(and (if (all-set? (prim-mask unsafe) flags)
|
|
(all-set? (prim-mask discard) flags)
|
|
(all-set? (prim-mask (or discard unrestricted)) flags))
|
|
(arity-okay? (primref-arity pr) (length e*))
|
|
(make-1seq 'effect (make-1seq* 'effect e*) void-rec))]
|
|
[else
|
|
ir]))]
|
|
[(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ; let-like expressions
|
|
(guard (fx= interface (length e*)))
|
|
(let ([body (dr body fuel)])
|
|
(if (eq? body void-rec)
|
|
(make-1seq 'effect (make-1seq* 'effect e*) void-rec)
|
|
`(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...)))]
|
|
[(letrec ((,x* ,e*) ...) ,[dr : body fuel -> body])
|
|
`(letrec ([,x* ,e*] ...) ,body)]
|
|
[(letrec* ((,x* ,e*) ...) ,[dr : body fuel -> body])
|
|
`(letrec* ([,x* ,e*] ...) ,body)]
|
|
[,pr
|
|
void-rec]
|
|
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
|
(make-1seq 'effect e void-rec)]
|
|
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
|
|
(make-1seq 'effect e void-rec)]
|
|
[(record ,rtd ,rtd-expr ,e* ...)
|
|
(make-1seq* 'effect (cons rtd-expr e*))]
|
|
[(record-ref ,rtd ,type ,index ,e)
|
|
(make-1seq 'effect e void-rec)]
|
|
[(record-type ,rtd ,e)
|
|
(make-1seq 'effect e void-rec)]
|
|
[(record-cd ,rcd ,rtd-expr ,e)
|
|
(make-1seq 'effect rtd-expr e void-rec)]
|
|
[(immutable-list (,e* ...) ,e)
|
|
(make-1seq 'effect (make-1seq* 'effect e*) e void-rec)]
|
|
[(moi) void-rec]
|
|
[else ir]
|
|
#;[else ($oops who "unrecognized record ~s" ir)])
|
|
|
|
; body of dr
|
|
(if (fx> fuel 0)
|
|
(Expr ir (fx- fuel 1))
|
|
ir)
|
|
)
|
|
)
|
|
|
|
(define make-seq
|
|
; ensures that the right subtree of the output seq is not a seq if the
|
|
; last argument is similarly constrained, to facilitate result-exp
|
|
(case-lambda
|
|
[(ctxt e1 e2)
|
|
(make-seq/no-drop ctxt (drop e1) e2)]
|
|
[(ctxt e1 e2 e3)
|
|
(make-seq ctxt (make-seq 'effect e1 e2) e3)]))
|
|
|
|
|
|
(define make-seq/no-drop
|
|
; like make-seq, but don't call drop on the not-last arguments to avoid
|
|
; quadratic runtime in some cases when it is known that can't be removed
|
|
(case-lambda
|
|
[(ctxt e1 e2)
|
|
(if (simple? e1)
|
|
e2
|
|
(if (and (eq? ctxt 'effect) (simple? e2))
|
|
e1 ; TODO: double check that it is not necessary to wrap e1 with $value
|
|
(nanopass-case (Lsrc Expr) e2
|
|
[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
|
|
[else `(seq ,e1 ,e2)])))]
|
|
[(ctxt e1 e2 e3)
|
|
(make-seq/no-drop ctxt (make-seq/no-drop 'effect e1 e2) e3)]))
|
|
|
|
(define make-1seq
|
|
; like `make-seq`, but preserves the requirement that all
|
|
; the arguments are single-valued
|
|
(case-lambda
|
|
[(ctxt e1 e2)
|
|
(make-seq ctxt (ensure-single-value e1 #f)
|
|
(ensure-single-value e2 #f))]
|
|
[(ctxt e1 e2 e3)
|
|
(make-1seq ctxt (make-1seq 'effect e1 e2) e3)]))
|
|
|
|
(define ensure-single-value
|
|
; the second argument is the ret-type of the expression in case it is known
|
|
(case-lambda
|
|
[(e1) (ensure-single-value e1 #f)]
|
|
[(e1 ret)
|
|
(if (or ret (single-valued? e1))
|
|
e1
|
|
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$value) ,e1))]))
|
|
|
|
#;(define (make-seq* ctxt e*) ; requires at least one operand
|
|
(if (null? (cdr e*))
|
|
(car e*)
|
|
(make-seq ctxt (car e*) (make-seq* ctxt (cdr e*)))))
|
|
|
|
(define (make-1seq* ctxt e*)
|
|
; requires at least one operand, unless for effect
|
|
; the last one must be single valued too.
|
|
(cond
|
|
[(null? e*)
|
|
(if (eq? ctxt 'effect)
|
|
void-rec
|
|
($oops make-1seq "empty operand list"))]
|
|
[else
|
|
(let loop ([e1 (car e*)] [e* (cdr e*)])
|
|
(if (null? e*)
|
|
(ensure-single-value e1 #f)
|
|
(make-seq ctxt (ensure-single-value e1 #f)
|
|
(loop (car e*) (cdr e*)))))]))
|
|
)
|
|
|
|
(define-record-type pred-$record/rtd
|
|
(fields rtd)
|
|
(nongenerative #{pred-$record/rtd wnquzwrp8wl515lhz2url8sjc-0})
|
|
(sealed #t))
|
|
|
|
(define-record-type pred-$record/ref
|
|
(fields ref)
|
|
(nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0})
|
|
(sealed #t))
|
|
|
|
(module (pred-env-empty pred-env-bottom
|
|
pred-env-add pred-env-remove/base pred-env-lookup
|
|
pred-env-intersect/base pred-env-union/super-base
|
|
pred-env-rebase
|
|
pred-intersect pred-union)
|
|
(import fxmap)
|
|
|
|
; a fake fxmap that is full of 'bottom
|
|
(define-record-type $bottom
|
|
(nongenerative #{$bottom koj7zosgebxioicmj4lgopip0-0})
|
|
(sealed #t))
|
|
|
|
(define bottom-fxmap (make-$bottom))
|
|
|
|
(define pred-env-empty empty-fxmap)
|
|
|
|
(define pred-env-bottom bottom-fxmap)
|
|
|
|
(define (pred-env-add/key types key pred)
|
|
(cond
|
|
[(and pred
|
|
(not (eq? pred 'ptr)) ; filter 'ptr to reduce the size
|
|
(not (eq? types bottom-fxmap)))
|
|
(let ([old (fxmap-ref types key #f)])
|
|
(cond
|
|
[(not old)
|
|
(fxmap-set types key pred)]
|
|
[else (let ([new (pred-intersect old pred)])
|
|
(cond
|
|
[(eq? new old) types]
|
|
[(eq? new 'bottom) bottom-fxmap]
|
|
[else (fxmap-set types key new)]))]))]
|
|
[else
|
|
types]))
|
|
|
|
(define (pred-env-add types x pred plxc)
|
|
(cond
|
|
[(and x (not (prelex-assigned x)))
|
|
(pred-env-add/key types (prelex-counter x plxc) pred)]
|
|
[else types]))
|
|
|
|
; When types is bottom-fxmap, the "association" is not removed
|
|
(define (pred-env-remove/base types x base plxc)
|
|
(cond
|
|
[(eq? types bottom-fxmap)
|
|
bottom-fxmap]
|
|
[else
|
|
(fxmap-remove/base types (prelex-counter x plxc) base)]))
|
|
|
|
(define (pred-env-lookup types x plxc)
|
|
(cond
|
|
[(eq? types bottom-fxmap)
|
|
'bottom]
|
|
[else
|
|
(and (not (prelex-assigned x))
|
|
(fxmap-ref types (prelex-counter x plxc) #f))]))
|
|
|
|
; This is conceptually the intersection of the types in `types` and `from`
|
|
; but since 'ptr is not stored to save space and time, the implementation
|
|
; looks like an union of the fxmaps.
|
|
; [missing 'ptr] _and_ 'vector -> 'vector
|
|
; 'box _and_ 'vector -> 'bottom
|
|
; 'number _and_ 'exact-integer -> 'exact-integer
|
|
(define (pred-env-intersect/base types from base)
|
|
(cond
|
|
[(or (eq? types bottom-fxmap)
|
|
(eq? from bottom-fxmap))
|
|
bottom-fxmap]
|
|
[(fx> (fxmap-changes from) (fxmap-changes types))
|
|
(pred-env-intersect/base from types base)]
|
|
[else
|
|
(let ([ret types])
|
|
(fxmap-for-each/diff (lambda (key x y)
|
|
(let ([z (fxmap-ref types key #f)])
|
|
;x-> from
|
|
;y-> base
|
|
;z-> types
|
|
(set! ret (pred-env-add/key ret key (pred-intersect x z)))))
|
|
(lambda (key x)
|
|
(set! ret (pred-env-add/key ret key x)))
|
|
(lambda (key x)
|
|
($impoops 'pred-env-intersect/base "unexpected value ~s in base environment ~s" x base))
|
|
from
|
|
base)
|
|
ret)]))
|
|
|
|
(define (pred-intersect x y)
|
|
(cond
|
|
[(predicate-implies? x y) x]
|
|
[(predicate-implies? y x) y]
|
|
[(or (predicate-implies-not? x y)
|
|
(predicate-implies-not? y x))
|
|
'bottom]
|
|
[(or (and (eq? x 'boolean) (eq? y 'true))
|
|
(and (eq? y 'boolean) (eq? x 'true)))
|
|
true-rec]
|
|
[else (or x y)])) ; if there is no exact option, at least keep the old value
|
|
|
|
; This is conceptually the union of the types in `types` and `from`
|
|
; but since 'ptr is not stored to save space and time, the implementation
|
|
; looks like an intersection of the fxmaps.
|
|
; [missing 'ptr] _or_ 'vector -> [missing 'ptr]
|
|
; 'box _or_ 'boolean -> [missing 'ptr]
|
|
; 'number _or_ 'exact-integer -> 'number
|
|
; *Internals auxilary function. Does not check bottom-fxmap.*
|
|
(define ($pred-env-union/from from base types new-base)
|
|
; Calculate the union of types and from, and intersect it with new-base
|
|
; Iterate over the difference of from and base.
|
|
(let ([ret new-base])
|
|
(fxmap-for-each/diff (lambda (key x y)
|
|
(let ([z (fxmap-ref types key #f)])
|
|
;x-> from
|
|
;y-> base
|
|
;z-> types
|
|
(set! ret (pred-env-add/key ret key (pred-union x z)))))
|
|
(lambda (key x)
|
|
(let ([z (fxmap-ref types key #f)])
|
|
;x-> from
|
|
;z-> types
|
|
(set! ret (pred-env-add/key ret key (pred-union x z)))))
|
|
(lambda (key x)
|
|
($impoops 'pred-env-union/from "unexpected value ~s in base environment ~s" x base))
|
|
from
|
|
base)
|
|
ret))
|
|
|
|
(define (pred-env-union/super-base types types/b
|
|
from from/b
|
|
base
|
|
new-base)
|
|
; Calculate the union of types and from, and intersect it with new-base
|
|
; Use the intermediate bases types/b and from/b to minimize the amount
|
|
; of operations required.
|
|
; In particular, base should be the base of types/b, from/b and new-base.
|
|
(cond
|
|
[(eq? new-base bottom-fxmap)
|
|
bottom-fxmap]
|
|
[(eq? types bottom-fxmap)
|
|
(pred-env-rebase from base new-base)]
|
|
[(eq? from bottom-fxmap)
|
|
(pred-env-rebase types base new-base)]
|
|
[else
|
|
(let ([size-types (fx- (fxmap-changes types) (fxmap-changes base))]
|
|
[size-from (fx- (fxmap-changes from) (fxmap-changes base))]
|
|
[size-new (fx+ (fx- (fxmap-changes types) (fxmap-changes types/b))
|
|
(fx- (fxmap-changes from) (fxmap-changes from/b)))])
|
|
(cond
|
|
[(and (fx<= size-types size-from) (fx<= size-types size-new))
|
|
($pred-env-union/from types base from new-base)]
|
|
[(fx<= size-from size-new)
|
|
($pred-env-union/from from base types new-base)]
|
|
[else
|
|
(let ([temp ($pred-env-union/from from from/b types new-base)])
|
|
; temp is never bottom-fxmap here
|
|
($pred-env-union/from types types/b from temp))]))]))
|
|
|
|
(define (pred-union x y)
|
|
(cond
|
|
[(predicate-implies? y x) x]
|
|
[(predicate-implies? x y) y]
|
|
[(find (lambda (t)
|
|
(and (predicate-implies? x t)
|
|
(predicate-implies? y t)))
|
|
'(char null-or-pair $record
|
|
gensym uninterned-symbol interned-symbol symbol
|
|
fixnum exact-integer flonum real number
|
|
boolean true ptr))] ; ensure they are order from more restrictive to less restrictive
|
|
[else #f]))
|
|
|
|
(define (pred-env-rebase types base new-base)
|
|
(cond
|
|
[(or (eq? types bottom-fxmap)
|
|
(eq? new-base bottom-fxmap))
|
|
bottom-fxmap]
|
|
[else
|
|
(let ([ret types])
|
|
(fxmap-for-each/diff (lambda (key x y)
|
|
(let ([z (fxmap-ref types key #f)])
|
|
;x-> new-base
|
|
;y-> base
|
|
;z-> types
|
|
(if (eq? x z)
|
|
(set! ret (fxmap-reset/base ret key new-base))
|
|
(set! ret (fxmap-advance/base ret key new-base)))))
|
|
(lambda (key x)
|
|
(let ([z (fxmap-ref types key #f)])
|
|
;x-> new-base
|
|
;z-> types
|
|
(if (eq? x z)
|
|
(set! ret (fxmap-reset/base ret key new-base))
|
|
(set! ret (fxmap-advance/base ret key new-base)))))
|
|
(lambda (key x)
|
|
($impoops 'pred-env-rebase "unexpected value ~s in base environment ~s" x base))
|
|
new-base
|
|
base)
|
|
ret)]))
|
|
)
|
|
|
|
(define (pred-env-add/ref types r pred plxc)
|
|
(nanopass-case (Lsrc Expr) r
|
|
[(ref ,maybe-src ,x)
|
|
(pred-env-add types x pred plxc)]
|
|
[else types]))
|
|
|
|
;copied from cp0.ss
|
|
(define (arity-okay? arity n)
|
|
(or (not arity) ; presumably system routine w/no recorded arity
|
|
(ormap
|
|
(lambda (a)
|
|
(or (fx= n a)
|
|
(and (fx< a 0) (fx>= n (fx- -1 a)))))
|
|
arity)))
|
|
|
|
;copied from cp0.ss
|
|
(define okay-to-copy?
|
|
(lambda (obj)
|
|
; okay to copy obj if (eq? (faslin (faslout x)) x) => #t or (in the case of numbers and characters)
|
|
; the value of (eq? x x) is unspecified
|
|
(or (and (symbol? obj) (not (uninterned-symbol? obj)))
|
|
(number? obj)
|
|
(char? obj)
|
|
(boolean? obj)
|
|
(null? obj)
|
|
(eqv? obj "")
|
|
(eqv? obj '#())
|
|
(eqv? obj '#vu8())
|
|
(eqv? obj '#vfx())
|
|
(eq? obj (void))
|
|
(eof-object? obj)
|
|
(bwp-object? obj)
|
|
(eq? obj '#6=#6#)
|
|
($unbound-object? obj)
|
|
(record-type-descriptor? obj)))) ;removed in datum->predicate
|
|
|
|
(define (datum->predicate d ir)
|
|
(cond
|
|
[(#3%$record? d) '$record] ;check first to avoid double representation of rtd
|
|
[(okay-to-copy? d) ir]
|
|
[(and (integer? d) (exact? d)) 'exact-integer]
|
|
[(pair? d) 'pair]
|
|
[(box? d) 'box]
|
|
[(vector? d) 'vector]
|
|
[(string? d) 'string]
|
|
[(bytevector? d) 'bytevector]
|
|
[(fxvector? d) 'fxvector]
|
|
[else #f]))
|
|
|
|
(define (rtd->record-predicate rtd extend?)
|
|
(cond
|
|
[(Lsrc? rtd)
|
|
(nanopass-case (Lsrc Expr) rtd
|
|
[(quote ,d)
|
|
(guard (record-type-descriptor? d))
|
|
(make-pred-$record/rtd d)]
|
|
[(ref ,maybe-src ,x)
|
|
(guard (not (prelex-assigned x)))
|
|
(make-pred-$record/ref x)]
|
|
[(record-type ,rtd ,e)
|
|
(rtd->record-predicate e extend?)]
|
|
[else (if (not extend?) 'bottom '$record)])]
|
|
[else (if (not extend?) 'bottom '$record)]))
|
|
|
|
; when extend is #f the result is a predicate that recognizes less values
|
|
; than the one in name. This is useful for reductions like
|
|
; (pred? x) ==> #t and (something x) ==> (#3%something x)
|
|
; when extend is #t the result is a predicate that recognizes more values
|
|
; than the one in name. This is useful for reductions like
|
|
; (pred? x) ==> #f and (something x) ==> <error>
|
|
; in case the non extended version is not #f, the extended version must be not #f
|
|
(define (primref-name->predicate name extend?)
|
|
(case name
|
|
[pair? 'pair]
|
|
[box? 'box]
|
|
[$record? '$record]
|
|
[fixnum? 'fixnum]
|
|
[flonum? 'flonum]
|
|
[real? 'real]
|
|
[number? 'number]
|
|
[vector? 'vector]
|
|
[string? 'string]
|
|
[bytevector? 'bytevector]
|
|
[fxvector? 'fxvector]
|
|
[gensym? 'gensym]
|
|
[uninterned-symbol? 'uninterned-symbol]
|
|
#;[interned-symbol? 'interned-symbol]
|
|
[symbol? 'symbol]
|
|
[char? 'char]
|
|
[boolean? 'boolean]
|
|
[procedure? 'procedure]
|
|
[not false-rec]
|
|
[null? null-rec]
|
|
[eof-object? eof-rec]
|
|
[bwp-object? bwp-rec]
|
|
[list? (if (not extend?) null-rec 'null-or-pair)]
|
|
[else ((if extend? cdr car)
|
|
(case name
|
|
[(record? record-type-descriptor?) '(bottom . $record)]
|
|
[(integer? rational?) '(exact-integer . real)]
|
|
[(cflonum?) '(flonum . number)]
|
|
[else '(#f . #f)]))])) ; this is used only to detect predicates.
|
|
|
|
(define (maybe-predicate? name)
|
|
(let ([name (symbol->string name)])
|
|
(and (>= (string-length name) 6)
|
|
(let loop ([n 0])
|
|
(or (fx= n 6)
|
|
(and (eq? (string-ref name n)
|
|
(string-ref "maybe-" n))
|
|
(loop (fx+ n 1))))))))
|
|
|
|
; nqm: no question mark
|
|
; this is almost duplicated code, but with more cases
|
|
; it's also useful to avoid the allocation
|
|
; of the temporal strings to transform: vector -> vector?
|
|
(define (primref-name/nqm->predicate name extend?)
|
|
(case name
|
|
[pair 'pair]
|
|
[box 'box]
|
|
[$record '$record]
|
|
[fixnum 'fixnum]
|
|
[flonum 'flonum]
|
|
[real 'real]
|
|
[number 'number]
|
|
[vector 'vector]
|
|
[string 'string]
|
|
[bytevector 'bytevector]
|
|
[fxvector 'fxvector]
|
|
[gensym 'gensym]
|
|
[uninterned-symbol 'uninterned-symbol]
|
|
[interned-symbol 'interned-symbol]
|
|
[symbol 'symbol]
|
|
[char 'char]
|
|
[bottom 'bottom] ;pseudo-predicate
|
|
[ptr 'ptr] ;pseudo-predicate
|
|
[boolean 'boolean]
|
|
[true 'true]
|
|
[procedure 'procedure]
|
|
[exact-integer 'exact-integer] ;fake-predicate
|
|
[void void-rec] ;fake-predicate
|
|
[null null-rec]
|
|
[eof-object eof-rec]
|
|
[bwp-object bwp-rec]
|
|
[list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate
|
|
[else ((if extend? cdr car)
|
|
(case name
|
|
[(record rtd) '(bottom . $record)]
|
|
[(bit length ufixnum pfixnum) '(bottom . fixnum)]
|
|
[(uint sub-uint) '(bottom . exact-integer)]
|
|
[(sint) '(fixnum . exact-integer)]
|
|
[(uinteger) '(bottom . real)]
|
|
[(integer rational) '(exact-integer . real)]
|
|
[(cflonum) '(flonum . number)]
|
|
[(sub-ptr) '(bottom . ptr)]
|
|
[else
|
|
(cond
|
|
[(not name) ; TODO: Move this case to the top?
|
|
'(#f . #f)]
|
|
[(pair? name) ; TODO: Move this case to the top?
|
|
(cond
|
|
[(equal? name '(ptr . ptr))
|
|
'(pair . pair)]
|
|
[else
|
|
'(bottom . pair)])]
|
|
[(maybe-predicate? name)
|
|
'(bottom . ptr)] ; for types like maybe-*
|
|
[else
|
|
'(bottom . true)])]))])) ; for all other types that exclude #f
|
|
|
|
(define (primref->predicate pr extend?)
|
|
(primref-name->predicate (primref-name pr) extend?))
|
|
|
|
(define (check-constant-is? x pred?)
|
|
(nanopass-case (Lsrc Expr) x
|
|
[(quote ,d) (pred? d)]
|
|
[else #f]))
|
|
|
|
; strange properties of bottom here:
|
|
; (implies? x bottom): only for x=bottom
|
|
; (implies? bottom y): always
|
|
; (implies-not? x bottom): never
|
|
; (implies-not? bottom y): never
|
|
; check (implies? x bottom) before (implies? x something)
|
|
(define (predicate-implies? x y)
|
|
(and x
|
|
y
|
|
(or (eq? x y)
|
|
(eq? x 'bottom)
|
|
(cond
|
|
[(Lsrc? y)
|
|
(and (Lsrc? x)
|
|
(nanopass-case (Lsrc Expr) y
|
|
[(quote ,d1)
|
|
(nanopass-case (Lsrc Expr) x
|
|
[(quote ,d2) (eqv? d1 d2)]
|
|
[else #f])]
|
|
[else #f]))]
|
|
[(pred-$record/rtd? y)
|
|
(and (pred-$record/rtd? x)
|
|
(let ([x-rtd (pred-$record/rtd-rtd x)]
|
|
[y-rtd (pred-$record/rtd-rtd y)])
|
|
(cond
|
|
[(record-type-sealed? y-rtd)
|
|
(eqv? x-rtd y-rtd)]
|
|
[else
|
|
(let loop ([x-rtd x-rtd])
|
|
(or (eqv? x-rtd y-rtd)
|
|
(let ([xp-rtd (record-type-parent x-rtd)])
|
|
(and xp-rtd (loop xp-rtd)))))])))]
|
|
[(pred-$record/ref? y)
|
|
(and (pred-$record/ref? x)
|
|
(eq? (pred-$record/ref-ref x)
|
|
(pred-$record/ref-ref y)))]
|
|
[(case y
|
|
[(null-or-pair) (or (eq? x 'pair)
|
|
(check-constant-is? x null?))]
|
|
[(fixnum) (check-constant-is? x target-fixnum?)]
|
|
[(exact-integer)
|
|
(or (eq? x 'fixnum)
|
|
(check-constant-is? x (lambda (x) (and (integer? x)
|
|
(exact? x)))))]
|
|
[(flonum) (check-constant-is? x flonum?)]
|
|
[(real) (or (eq? x 'fixnum)
|
|
(eq? x 'exact-integer)
|
|
(eq? x 'flonum)
|
|
(check-constant-is? x real?))]
|
|
[(number) (or (eq? x 'fixnum)
|
|
(eq? x 'exact-integer)
|
|
(eq? x 'flonum)
|
|
(eq? x 'real)
|
|
(check-constant-is? x number?))]
|
|
[(gensym) (check-constant-is? x gensym?)]
|
|
[(uninterned-symbol) (check-constant-is? x uninterned-symbol?)]
|
|
[(interned-symbol) (check-constant-is? x (lambda (x)
|
|
(and (symbol? x)
|
|
(not (gensym? x))
|
|
(not (uninterned-symbol? x)))))]
|
|
[(symbol) (or (eq? x 'gensym)
|
|
(eq? x 'uninterned-symbol)
|
|
(eq? x 'interned-symbol)
|
|
(check-constant-is? x symbol?))]
|
|
[(char) (check-constant-is? x char?)]
|
|
[(boolean) (check-constant-is? x boolean?)]
|
|
[(true) (and (not (check-constant-is? x not))
|
|
(not (eq? x 'boolean))
|
|
(not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f
|
|
[($record) (or (pred-$record/rtd? x)
|
|
(pred-$record/ref? x)
|
|
(check-constant-is? x #3%$record?))]
|
|
[(vector) (check-constant-is? x vector?)] ; i.e. '#()
|
|
[(string) (check-constant-is? x string?)] ; i.e. ""
|
|
[(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8()
|
|
[(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx()
|
|
[(ptr) #t]
|
|
[else #f])]
|
|
[else #f]))))
|
|
|
|
(define (predicate-implies-not? x y)
|
|
(and x
|
|
y
|
|
; a pred-$record/ref may be any other kind or record
|
|
(not (and (pred-$record/ref? x)
|
|
(predicate-implies? y '$record)))
|
|
(not (and (pred-$record/ref? y)
|
|
(predicate-implies? x '$record)))
|
|
; boolean and true may be a #t
|
|
(not (and (eq? x 'boolean)
|
|
(eq? y 'true)))
|
|
(not (and (eq? y 'boolean)
|
|
(eq? x 'true)))
|
|
; the other types are included or disjoint
|
|
(not (predicate-implies? x y))
|
|
(not (predicate-implies? y x))))
|
|
|
|
(define (primref->result-predicate pr arity)
|
|
(define parameterlike? box?)
|
|
(define parameterlike-type unbox)
|
|
(let ([type ($sgetprop (primref-name pr) '*result-type* #f)])
|
|
(and type
|
|
(cond
|
|
[(parameterlike? type)
|
|
(cond
|
|
[(not arity) ; unknown
|
|
(pred-union void-rec
|
|
(primref-name/nqm->predicate (parameterlike-type type) #t))]
|
|
[(fx= arity 0)
|
|
(primref-name/nqm->predicate (parameterlike-type type) #t)]
|
|
[else
|
|
void-rec])]
|
|
[else
|
|
(primref-name/nqm->predicate type #t)]))))
|
|
|
|
(define (primref->argument-predicate pr pos arity extend?)
|
|
(let ([arguments-type ($sgetprop (primref-name pr) '*arguments-type* #f)])
|
|
(and arguments-type
|
|
(cond
|
|
[(fx< pos (vector-length arguments-type))
|
|
(primref-name/nqm->predicate (vector-ref arguments-type pos) extend?)]
|
|
[(not arity)
|
|
#f]
|
|
[(fx< pos (fx- arity 1))
|
|
(let ([rest ($sgetprop (primref-name pr) '*rest-type* #f)])
|
|
(primref-name/nqm->predicate rest extend?))]
|
|
[else
|
|
(let ([last ($sgetprop (primref-name pr) '*last-type* #f)])
|
|
(cond
|
|
[last
|
|
(primref-name/nqm->predicate last extend?)]
|
|
[else
|
|
(let ([rest ($sgetprop (primref-name pr) '*rest-type* #f)])
|
|
(primref-name/nqm->predicate rest extend?))]))]))))
|
|
|
|
(define (primref->unsafe-primref pr)
|
|
(lookup-primref 3 (primref-name pr)))
|
|
|
|
|
|
(module ()
|
|
(with-output-language (Lsrc Expr)
|
|
|
|
(define get-type-key)
|
|
|
|
(define (expr-is-rtd? x types)
|
|
(nanopass-case (Lsrc Expr) x ; ensure that it is actually a rtd
|
|
[(quote ,d)
|
|
(record-type-descriptor? d)]
|
|
[(record-type ,rtd ,e) #t]
|
|
; TODO: extend the type system to include rtd
|
|
[else #f]))
|
|
|
|
; Similar to the define-inline in other passes, but the result can't be #f.
|
|
; The arguments have already been analyzed, and the type of the result
|
|
; is available with the macro (get-type <arg>).
|
|
; A good default is (values `(call ,preinfo ,pr ,<args> ...) ret ntypes #f #f)
|
|
; In particular, ntypes has all the types discovered in the arguments and
|
|
; the types implied by the signatures. For the types before the arguments
|
|
; were analyzed, use oldtypes. (See exact? for an example.)
|
|
; Also, prim-name and level repeat the information available in pr,
|
|
; and ctxt and plxc are available.
|
|
(define-syntax define-specialize
|
|
(lambda (x)
|
|
(define (make-get-type-name id)
|
|
(datum->syntax-object id
|
|
(gensym (string-append (symbol->string (syntax->datum id))
|
|
"-ret-type"))))
|
|
(syntax-case x ()
|
|
[(_key lev prim clause ...)
|
|
(identifier? #'prim)
|
|
#'(_key lev (prim) clause ...)]
|
|
[(_key lev (prim ...) clause ...)
|
|
(andmap identifier? #'(prim ...))
|
|
(with-implicit (_key level prim-name preinfo pr ret ctxt ntypes oldtypes plxc)
|
|
(with-syntax
|
|
([key (case (datum lev)
|
|
[(2) #'cptypes2]
|
|
[(3) #'cptypes3]
|
|
[else ($oops #f "invalid inline level ~s" (datum lev))])]
|
|
[body
|
|
(let loop ([clauses #'(clause ...)])
|
|
(if (null? clauses)
|
|
#'(unhandled preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
|
|
(with-syntax ((rest (loop (cdr clauses))))
|
|
(syntax-case (car clauses) ()
|
|
[((x ...) b1 b2 ...)
|
|
#;guard: (andmap identifier? #'(x ...))
|
|
(with-syntax ([n (length #'(x ...))]
|
|
[(x_r ...) (map make-get-type-name #'(x ...))])
|
|
#'(if (eq? count n)
|
|
(apply
|
|
(apply (lambda (x ...)
|
|
(lambda (x_r ...)
|
|
(begin (define-property x get-type-key #'x_r) ...)
|
|
(begin b1 b2 ...))) e*) r*)
|
|
rest))]
|
|
[(r b1 b2 ...)
|
|
#;guard: (identifier? #'r)
|
|
(with-syntax ([r_r (make-get-type-name #'r)])
|
|
#'(apply
|
|
(apply (lambda r
|
|
(lambda r_r
|
|
(define-property r get-type-key #'r_r)
|
|
b1 b2 ...)) e*) r*))]
|
|
[((x ... . r) b1 b2 ...)
|
|
#;guard: (and (andmap identifier? #'(x ...)) (identifier? #'r))
|
|
(with-syntax ([n (length #'(x ...))]
|
|
[(x_r ...) (map make-get-type-name #'(x ...))]
|
|
[r_r (make-get-type-name #'r)])
|
|
#'(if (fx>= count n)
|
|
(apply
|
|
(apply (lambda (x ... . r)
|
|
(lambda (x_r ... . r_r)
|
|
(begin (define-property x get-type-key #'x_r) ...)
|
|
(define-property r get-type-key #'r_r)
|
|
b1 b2 ...)) e*) r*)
|
|
rest))]))))])
|
|
(for-each
|
|
(lambda (sym-name)
|
|
(let ([sym-key (datum key)])
|
|
(if (getprop sym-name sym-key #f)
|
|
(warningf #f "duplicate ~s handler for ~s" sym-key sym-name)
|
|
(putprop sym-name sym-key #t))
|
|
(unless (all-set?
|
|
(case (datum lev)
|
|
[(2) (prim-mask cptypes2)]
|
|
[(3) (prim-mask cptypes3)])
|
|
($sgetprop sym-name '*flags* 0))
|
|
(warningf #f "undeclared ~s handler for ~s~%" sym-key sym-name))))
|
|
(datum (prim ...)))
|
|
#'(begin
|
|
(let ([handler (lambda (preinfo pr e* ret r* ctxt ntypes oldtypes plxc unhandled)
|
|
(let ([level (if (all-set? (prim-mask unsafe) (primref-flags pr)) 3 2)]
|
|
[prim-name 'prim]
|
|
[count (length e*)])
|
|
body))])
|
|
($sputprop 'prim 'key handler)) ...)))])))
|
|
|
|
; Similar to define-specialize, but the arguments are not analyzed yet,
|
|
; so it's necesary to use Expr, Expr/call or a similar function to analyze them.
|
|
; Also, the variables ret, ntypes and (get-type <arg>) are not available.
|
|
(define-syntax define-specialize/unrestricted
|
|
(lambda (x)
|
|
(define (make-get-type-name id)
|
|
(datum->syntax-object id
|
|
(gensym (string-append (symbol->string (syntax->datum id))
|
|
"-ret-type"))))
|
|
(syntax-case x ()
|
|
[(_key lev prim clause ...)
|
|
(identifier? #'prim)
|
|
#'(_key lev (prim) clause ...)]
|
|
[(_key lev (prim ...) clause ...)
|
|
(andmap identifier? #'(prim ...))
|
|
(with-implicit (_key level prim-name preinfo pr ctxt oldtypes plxc)
|
|
(with-syntax
|
|
([key (case (datum lev)
|
|
[(2) #'cptypes2x]
|
|
[(3) #'cptypes3x]
|
|
[else ($oops #f "invalid inline level ~s" (datum lev))])]
|
|
[body
|
|
(let loop ([clauses #'(clause ...)])
|
|
(if (null? clauses)
|
|
#'(unhandled preinfo pr e* ctxt oldtypes plxc)
|
|
(with-syntax ((rest (loop (cdr clauses))))
|
|
(syntax-case (car clauses) ()
|
|
[((x ...) b1 b2 ...)
|
|
#;guard: (andmap identifier? #'(x ...))
|
|
(with-syntax ([n (length #'(x ...))])
|
|
#'(if (eq? count n)
|
|
(apply (lambda (x ...)
|
|
b1 b2 ...) e*)
|
|
rest))]
|
|
[(r b1 b2 ...)
|
|
#;guard: (identifier? #'r)
|
|
#'(apply
|
|
(lambda r
|
|
b1 b2 ...) e*)]
|
|
[((x ... . r) b1 b2 ...)
|
|
#;guard: (and (andmap identifier? #'(x ...)) (identifier? #'r))
|
|
(with-syntax ([n (length #'(x ...))])
|
|
#'(if (fx>= count n)
|
|
(apply
|
|
(lambda (x ... . r)
|
|
b1 b2 ...) e*)
|
|
rest))]))))])
|
|
(for-each
|
|
(lambda (sym-name)
|
|
(let ([sym-key (datum key)])
|
|
(if (getprop sym-name sym-key #f)
|
|
(warningf #f "duplicate ~s handler for ~s" sym-key sym-name)
|
|
(putprop sym-name sym-key #t))
|
|
(unless (all-set?
|
|
(case (datum lev)
|
|
[(2) (prim-mask cptypes2x)]
|
|
[(3) (prim-mask cptypes3x)])
|
|
($sgetprop sym-name '*flags* 0))
|
|
(warningf #f "undeclared ~s handler for ~s~%" sym-key sym-name))))
|
|
(datum (prim ...)))
|
|
#'(begin
|
|
(let ([handler (lambda (preinfo pr e* ctxt oldtypes plxc unhandled)
|
|
(let ([level (if (all-set? (prim-mask unsafe) (primref-flags pr)) 3 2)]
|
|
[prim-name 'prim]
|
|
[count (length e*)])
|
|
body))])
|
|
($sputprop 'prim 'key handler)) ...)))])))
|
|
|
|
(define-syntax (get-type stx)
|
|
(lambda (lookup)
|
|
(syntax-case stx ()
|
|
[(_ id) (or (lookup #'id #'get-type-key)
|
|
($oops 'get-type "invalid identifier ~s" #'id))])))
|
|
|
|
(define-specialize 2 (eq? eqv?)
|
|
[(e1 e2) (let ([r1 (get-type e1)]
|
|
[r2 (get-type e2)])
|
|
(cond
|
|
[(or (predicate-implies-not? r1 r2)
|
|
(predicate-implies-not? r2 r1))
|
|
(values (make-seq ctxt e1 e2 false-rec)
|
|
false-rec ntypes #f #f)]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,e1 ,e2)
|
|
ret
|
|
ntypes
|
|
(and (eq? ctxt 'test)
|
|
(pred-env-add/ref
|
|
(pred-env-add/ref ntypes e1 r2 plxc)
|
|
e2 r1 plxc))
|
|
#f)]))])
|
|
|
|
(define-specialize 2 list
|
|
[() (values null-rec null-rec ntypes #f #f)] ; should have been reduced by cp0
|
|
[e* (values `(call ,preinfo ,pr ,e* ...) 'pair ntypes #f #f)])
|
|
|
|
(define-specialize 2 $record
|
|
[(rtd . e*) (values `(call ,preinfo ,pr ,rtd ,e* ...) (rtd->record-predicate rtd #t) ntypes #f #f)])
|
|
|
|
(define-specialize 2 (record? $sealed-record?)
|
|
[(val rtd) (let* ([val-type (get-type val)]
|
|
[to-unsafe (and (fx= level 2)
|
|
(expr-is-rtd? rtd oldtypes))] ; use the old types
|
|
[level (if to-unsafe 3 level)]
|
|
[pr (if to-unsafe
|
|
(primref->unsafe-primref pr)
|
|
pr)])
|
|
(cond
|
|
[(predicate-implies? val-type (rtd->record-predicate rtd #f))
|
|
(values (make-seq ctxt val rtd true-rec)
|
|
true-rec ntypes #f #f)]
|
|
[(predicate-implies-not? val-type (rtd->record-predicate rtd #t))
|
|
(cond
|
|
[(fx= level 3)
|
|
(let ([rtd (ensure-single-value rtd (get-type rtd))]) ; ensure that rtd is a single valued expression
|
|
(values (make-seq ctxt val rtd false-rec)
|
|
false-rec ntypes #f #f))]
|
|
[else
|
|
(values (make-seq ctxt `(call ,preinfo ,pr ,val ,rtd) false-rec)
|
|
false-rec ntypes #f #f)])]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,val ,rtd)
|
|
ret
|
|
ntypes
|
|
(and (eq? ctxt 'test)
|
|
(pred-env-add/ref ntypes val (rtd->record-predicate rtd #t) plxc))
|
|
#f)]))])
|
|
|
|
(define-specialize 2 exact?
|
|
[(n) (let ([r (get-type n)])
|
|
(cond
|
|
[(predicate-implies? r 'exact-integer)
|
|
(values (make-seq ctxt n true-rec)
|
|
true-rec ntypes #f #f)]
|
|
[(predicate-implies? r 'flonum)
|
|
(values (make-seq ctxt n false-rec)
|
|
false-rec ntypes #f #f)]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))])
|
|
|
|
(define-specialize 2 inexact?
|
|
[(n) (let ([r (get-type n)])
|
|
(cond
|
|
[(predicate-implies? r 'exact-integer)
|
|
(values (make-seq ctxt n false-rec)
|
|
false-rec ntypes #f #f)]
|
|
[(predicate-implies? r 'flonum)
|
|
(values (make-seq ctxt n true-rec)
|
|
true-rec ntypes #f #f)]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))])
|
|
|
|
(define-specialize 2 atan
|
|
[(n) (let ([r (get-type n)])
|
|
(cond
|
|
[(predicate-implies-not? r 'number)
|
|
(values `(call ,preinfo ,pr ,n)
|
|
'bottom pred-env-bottom #f #f)]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,n) ret
|
|
(pred-env-add/ref ntypes n 'number plxc) #f #f)]))]
|
|
[(x y) (let ([rx (get-type x)]
|
|
[ry (get-type y)])
|
|
(cond
|
|
[(or (predicate-implies-not? rx 'real)
|
|
(predicate-implies-not? ry 'real))
|
|
(values `(call ,preinfo ,pr ,x ,y)
|
|
'bottom pred-env-bottom #f #f)]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,x ,y) ret
|
|
(pred-env-add/ref (pred-env-add/ref ntypes
|
|
x 'real plxc)
|
|
y 'real plxc)
|
|
#f #f)]))])
|
|
|
|
(define-specialize 2 char-name
|
|
[(n) (let ([r (get-type n)]
|
|
[ir `(call ,preinfo ,pr ,n)])
|
|
(cond
|
|
[(predicate-implies? r 'char)
|
|
(values ir 'ptr ntypes #f #f)] ; should be maybe-symbol
|
|
[(predicate-implies? r 'symbol)
|
|
(values ir 'ptr ntypes #f #f)] ; should be maybe-char
|
|
[(and (predicate-implies-not? r 'char)
|
|
(predicate-implies-not? r 'symbol))
|
|
(values ir 'bottom pred-env-bottom #f #f)]
|
|
[else
|
|
(values ir 'ptr ; should be maybe-(union 'char 'symbol)
|
|
(pred-env-add/ref ntypes n 'true plxc) #f #f)]))] ; should be (union 'char 'symbol)
|
|
[(n c) (let ([rn (get-type n)]
|
|
[rc (get-type c)]
|
|
[ir `(call ,preinfo ,pr ,n ,c)])
|
|
(cond
|
|
[(or (predicate-implies-not? rn 'symbol)
|
|
(predicate-implies-not? rc 'ptr)) ; should be maybe-char
|
|
(values ir 'bottom pred-env-bottom #f #f)]
|
|
[else
|
|
(values ir void-rec
|
|
(pred-env-add/ref (pred-env-add/ref ntypes
|
|
n 'symbol plxc)
|
|
c 'ptr plxc) ; should be maybe-char
|
|
#f #f)]))])
|
|
|
|
(define-specialize/unrestricted 2 call-with-values
|
|
[(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1)
|
|
(Expr/call e1 'value oldtypes oldtypes plxc)])
|
|
(let-values ([(e2 ret2 types2 t-types2 f-types2)
|
|
(Expr/call e2 ctxt types1 oldtypes plxc)])
|
|
(values `(call ,preinfo ,pr ,e1 ,e2)
|
|
(if (predicate-implies? ret1 'bottom) ; check if necesary
|
|
'bottom
|
|
ret2)
|
|
types2 t-types2 f-types2)))])
|
|
|
|
(define-specialize/unrestricted 2 apply
|
|
[(proc . e*) (let-values ([(e* r* t* t-t* f-t*)
|
|
(map-values 5 (lambda (e) (Expr/main e 'value oldtypes plxc)) e*)])
|
|
(let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)])
|
|
(let-values ([(proc retproc typesproc t-typesproc f-typesproc)
|
|
(Expr/call proc ctxt mtypes oldtypes plxc)])
|
|
(values `(call ,preinfo ,pr ,proc ,e* ...)
|
|
retproc typesproc t-typesproc f-typesproc))))])
|
|
|
|
(define-specialize/unrestricted 2 $apply
|
|
[(proc n args) (let*-values ([(n rn tn t-tn f-tn)
|
|
(Expr/main n 'value oldtypes plxc)]
|
|
[(args rargs targs t-targs f-targs)
|
|
(Expr/main args 'value oldtypes plxc)])
|
|
(let* ([predn (primref->argument-predicate pr 1 3 #t)]
|
|
[tn (if (predicate-implies-not? rn predn)
|
|
'bottom
|
|
tn)]
|
|
[tn (pred-env-add/ref tn n predn plxc)]
|
|
[predargs (primref->argument-predicate pr 2 3 #t)]
|
|
[targs (if (predicate-implies-not? rargs predargs)
|
|
'bottom
|
|
targs)]
|
|
[targs (pred-env-add/ref targs args predargs plxc)]
|
|
[mtypes (pred-env-intersect/base tn targs oldtypes)])
|
|
(let-values ([(proc retproc typesproc t-typesproc f-typesproc)
|
|
(Expr/call proc ctxt mtypes oldtypes plxc)])
|
|
(values `(call ,preinfo ,pr ,proc ,n ,args)
|
|
retproc typesproc t-typesproc f-typesproc))))])
|
|
|
|
(let ()
|
|
(define (handle-dynamic-wind critical? in body out ctxt oldtypes plxc)
|
|
(let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?)
|
|
(if critical?
|
|
(Expr/main critical? 'value oldtypes plxc)
|
|
(values #f #f oldtypes #f #f))]
|
|
[(ìn rin tin t-tin f-tin)
|
|
(Expr/call in 'value tcritical? oldtypes plxc)]
|
|
[(body rbody tbody t-tbody f-tbody)
|
|
(Expr/call body 'value tin oldtypes plxc)] ; it's almost possible to use ctxt instead of 'value here
|
|
[(out rout tout t-tout f-tout)
|
|
(Expr/call out 'value tin oldtypes plxc)]) ; use tin instead of tbody in case of error or jump.
|
|
(let* ([n-types (pred-env-intersect/base tbody tout tin)]
|
|
[t-types (and (eq? ctxt 'test)
|
|
t-tbody
|
|
(pred-env-rebase t-tbody tin n-types))]
|
|
[f-types (and (eq? ctxt 'test)
|
|
f-tbody
|
|
(pred-env-rebase f-tbody tin n-types))])
|
|
(values critical? in body out rbody n-types t-types f-types))))
|
|
|
|
(define-specialize/unrestricted 2 r6rs:dynamic-wind
|
|
[(in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
|
|
(handle-dynamic-wind #f in body out ctxt oldtypes plxc)])
|
|
(values `(call ,preinfo ,pr ,in ,body ,out)
|
|
ret n-types t-types f-types))])
|
|
(define-specialize/unrestricted 2 dynamic-wind
|
|
[(in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
|
|
(handle-dynamic-wind #f in body out ctxt oldtypes plxc)])
|
|
(values `(call ,preinfo ,pr ,in ,body ,out)
|
|
ret n-types t-types f-types))]
|
|
[(critical? in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
|
|
(handle-dynamic-wind critical? in body out ctxt oldtypes plxc)])
|
|
(values `(call ,preinfo ,pr ,critical? ,in ,body ,out)
|
|
ret n-types t-types f-types))])
|
|
)
|
|
|
|
))
|
|
|
|
(with-output-language (Lsrc Expr)
|
|
|
|
(define (fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
|
|
; assume they never raise an error
|
|
; TODO?: Move to a define-specialize
|
|
(let ([val (car e*)]
|
|
[val-type (car r*)])
|
|
(cond
|
|
[(predicate-implies? val-type (primref->predicate pr #f))
|
|
(values (make-seq ctxt val true-rec)
|
|
true-rec ntypes #f #f)]
|
|
[(predicate-implies-not? val-type (primref->predicate pr #t))
|
|
(values (make-seq ctxt val false-rec)
|
|
false-rec ntypes #f #f)]
|
|
[else
|
|
(values `(call ,preinfo ,pr ,val)
|
|
ret
|
|
ntypes
|
|
(and (eq? ctxt 'test)
|
|
(pred-env-add/ref ntypes val (primref->predicate pr #t) plxc))
|
|
#f)])))
|
|
|
|
(define (fold-call/primref preinfo pr e* ctxt oldtypes plxc)
|
|
(fold-primref/unrestricted preinfo pr e* ctxt oldtypes plxc))
|
|
|
|
(define (fold-primref/unrestricted preinfo pr e* ctxt oldtypes plxc)
|
|
(let* ([flags (primref-flags pr)]
|
|
[prim-name (primref-name pr)]
|
|
[handler (or (and (all-set? (prim-mask unsafe) flags)
|
|
(all-set? (prim-mask cptypes3x) flags)
|
|
($sgetprop prim-name 'cptypes3x #f))
|
|
(and (all-set? (prim-mask cptypes2x) flags)
|
|
($sgetprop prim-name 'cptypes2x #f)))])
|
|
(if handler
|
|
(call-with-values
|
|
(lambda () (handler preinfo pr e* ctxt oldtypes plxc fold-primref/next))
|
|
(case-lambda
|
|
[(ir2 ret2 types2 t-types2 f-types2)
|
|
(values ir2 ret2 types2 t-types2 f-types2)]
|
|
[else ($oops 'fold-primref "result of inline handler can't be #f")]))
|
|
(fold-primref/next preinfo pr e* ctxt oldtypes plxc))))
|
|
|
|
(define (fold-primref/next preinfo pr e* ctxt oldtypes plxc)
|
|
(let-values ([(t e* r* t* t-t* f-t*)
|
|
(map-Expr/delayed e* oldtypes plxc)])
|
|
(let ([ret (primref->result-predicate pr (length e*))])
|
|
(let-values ([(ret t)
|
|
(let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
|
|
(if (null? e*)
|
|
(values ret t)
|
|
(let ([pred (primref->argument-predicate pr n (length e*) #t)])
|
|
(loop (cdr e*)
|
|
(cdr r*)
|
|
(fx+ n 1)
|
|
(if (predicate-implies-not? (car r*) pred)
|
|
'bottom
|
|
ret)
|
|
(pred-env-add/ref t (car e*) pred plxc)))))])
|
|
(cond
|
|
[(or (predicate-implies? ret 'bottom)
|
|
(not (arity-okay? (primref-arity pr) (length e*))))
|
|
(fold-primref/default preinfo pr e* 'bottom r* ctxt pred-env-bottom oldtypes plxc)]
|
|
[else
|
|
(let* ([to-unsafe (and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
|
|
(all-set? (prim-mask safeongoodargs) (primref-flags pr))
|
|
(andmap (lambda (r n)
|
|
(predicate-implies? r
|
|
(primref->argument-predicate pr n (length e*) #f)))
|
|
r* (enumerate r*)))]
|
|
[pr (if to-unsafe
|
|
(primref->unsafe-primref pr)
|
|
pr)])
|
|
(fold-primref/normal preinfo pr e* ret r* ctxt t oldtypes plxc))])))))
|
|
|
|
(define (fold-primref/normal preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
|
|
(cond
|
|
[(and (fx= (length e*) 1) (primref->predicate pr #t))
|
|
(fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc)]
|
|
[else
|
|
(let* ([flags (primref-flags pr)]
|
|
[prim-name (primref-name pr)]
|
|
[handler (or (and (all-set? (prim-mask unsafe) flags)
|
|
(all-set? (prim-mask cptypes3) flags)
|
|
($sgetprop prim-name 'cptypes3 #f))
|
|
(and (all-set? (prim-mask cptypes2) flags)
|
|
($sgetprop prim-name 'cptypes2 #f)))])
|
|
(if handler
|
|
(call-with-values
|
|
(lambda () (handler preinfo pr e* ret r* ctxt ntypes oldtypes plxc fold-primref/default))
|
|
(case-lambda
|
|
[(ir2 ret2 types2 t-types2 f-types2)
|
|
(values ir2 ret2 types2 t-types2 f-types2)]
|
|
[else ($oops 'fold-primref "result of inline handler can't be #f")]))
|
|
(fold-primref/default preinfo pr e* ret r* ctxt ntypes oldtypes plxc)))]))
|
|
|
|
(define (fold-primref/default preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
|
|
(values `(call ,preinfo ,pr ,e* ...) ret ntypes #f #f))
|
|
|
|
(define (fold-call/lambda preinfo e0 e* ctxt oldtypes plxc)
|
|
(define (finish preinfo preinfo2 x* interface body e* r* ntypes)
|
|
(let ([ntypes/x (fold-left (lambda (t x p) (pred-env-add t x p plxc)) ntypes x* r*)])
|
|
(let*-values ([(body ret n-types/x t-types/x f-types/x)
|
|
(Expr/main body ctxt ntypes/x plxc)]
|
|
[(n-types t-types f-types)
|
|
(pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)])
|
|
(values `(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
|
ret n-types t-types f-types))))
|
|
(define (bad-arity preinfo e0 e* ctxt ntypes)
|
|
(let*-values ([(e0 ret0 n-types0 t-types0 f-types0)
|
|
(Expr/main e0 'value ntypes plxc)])
|
|
(values `(call ,preinfo ,e0 ,e* ...)
|
|
'bottom pred-env-bottom #f #f)))
|
|
(define (cut-r* r* n)
|
|
(let loop ([i n] [r* r*])
|
|
(if (fx= i 0)
|
|
(list (if (null? r*) null-rec 'pair))
|
|
(cons (car r*) (loop (fx- i 1) (cdr r*))))))
|
|
(let*-values ([(ntypes e* r* t* t-t* f-t*)
|
|
(map-Expr/delayed e* oldtypes plxc)])
|
|
(nanopass-case (Lsrc Expr) e0
|
|
[(case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...)
|
|
(let ([len (length e*)])
|
|
(let loop ([x** x**] [interface* interface*] [body* body*])
|
|
(cond
|
|
[(null? interface*)
|
|
(bad-arity preinfo e0 e* ctxt ntypes)]
|
|
[else
|
|
(let ([interface (car interface*)])
|
|
(cond
|
|
[(fx< interface 0)
|
|
(let ([nfixed (fxlognot interface)])
|
|
(if (fx>= len nfixed)
|
|
(let ([r* (cut-r* r* nfixed)])
|
|
(finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes))
|
|
(loop (cdr x**) (cdr interface*) (cdr body*))))]
|
|
[else
|
|
(if (fx= interface len)
|
|
(finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes)
|
|
(loop (cdr x**) (cdr interface*) (cdr body*)))]))])))])))
|
|
|
|
(define (pred-env-triple-filter/base ntypes ttypes ftypes x* ctxt base plxc)
|
|
(let* ([ttypes (and (not (eq? ntypes ttypes)) ttypes)]
|
|
[ntypes (and (not (eq? ntypes ttypes)) ntypes)]
|
|
[ntypes (fold-left (lambda (f x) (pred-env-remove/base f x base plxc)) ntypes x*)]
|
|
[ttypes (and (eq? ctxt 'test)
|
|
ttypes
|
|
(fold-left (lambda (f x) (pred-env-remove/base f x ntypes plxc)) ttypes x*))]
|
|
[ftypes (and (eq? ctxt 'test)
|
|
ftypes
|
|
(fold-left (lambda (f x) (pred-env-remove/base f x ntypes plxc)) ftypes x*))])
|
|
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
|
|
(values ntypes ttypes ftypes)))
|
|
|
|
(define (fold-call/other preinfo e0 e* ctxt oldtypes plxc)
|
|
(let*-values ([(ntypes e* r* t* t-t* f-t*)
|
|
(map-Expr/delayed e* oldtypes plxc)]
|
|
[(e0 ret0 types0 t-types0 f-types0)
|
|
(Expr/call e0 'value ntypes oldtypes plxc)])
|
|
(values `(call ,preinfo ,e0 ,e* ...)
|
|
ret0 types0 t-types0 f-types0)))
|
|
|
|
(define (map-Expr/delayed e* oldtypes plxc)
|
|
(define first-pass* (map (lambda (e)
|
|
(nanopass-case (Lsrc Expr) e
|
|
[(case-lambda ,preinfo ,cl* ...)
|
|
(cons 'delayed e)]
|
|
[else
|
|
(cons 'ready
|
|
(call-with-values
|
|
(lambda () (Expr/main e 'value oldtypes plxc))
|
|
list))]))
|
|
e*))
|
|
(define fp-types (fold-left (lambda (t x)
|
|
(if (eq? (car x) 'ready)
|
|
(pred-env-intersect/base t (caddr (cdr x)) oldtypes)
|
|
t))
|
|
oldtypes
|
|
first-pass*))
|
|
(define second-pass* (map (lambda (e)
|
|
(cond
|
|
[(eq? (car e) 'delayed)
|
|
(call-with-values
|
|
(lambda () (Expr/main (cdr e) 'value fp-types plxc))
|
|
list)]
|
|
[else
|
|
(cdr e)]))
|
|
first-pass*))
|
|
(define sp-types fp-types) ; since they are only lambdas, they add no new info.
|
|
(define untransposed (if (null? second-pass*)
|
|
'(() () () () ())
|
|
(apply map list second-pass*)))
|
|
(apply values sp-types untransposed))
|
|
|
|
(define (map-values l f v*)
|
|
; `l` is the default lenght, in case `v*` is null.
|
|
(if (null? v*)
|
|
(apply values (make-list l '()))
|
|
(let ()
|
|
(define transposed (map (lambda (x)
|
|
(call-with-values
|
|
(lambda () (f x))
|
|
list))
|
|
v*))
|
|
(define good (apply map list transposed))
|
|
(apply values good))))
|
|
|
|
(define (Expr/fix-tf-types ir ctxt types plxc)
|
|
(let-values ([(ir ret types t-types f-types)
|
|
(Expr/main ir ctxt types plxc)])
|
|
(values ir ret
|
|
types
|
|
(if (predicate-implies? ret false-rec)
|
|
pred-env-bottom
|
|
(or t-types types))
|
|
(if (predicate-implies? ret 'true)
|
|
pred-env-bottom
|
|
(or f-types types)))))
|
|
|
|
(define (Expr/call ir ctxt types outtypes plxc) ; TODO: Add arity
|
|
(nanopass-case (Lsrc Expr) ir
|
|
[,pr (values pr (primref->result-predicate pr #f) types #f #f)]
|
|
[(case-lambda ,preinfo ,cl* ...)
|
|
(let loop ([cl* cl*]
|
|
[rev-rcl* '()]
|
|
[rret 'bottom]
|
|
[rtypes types]
|
|
[rt-types (and (eq? ctxt 'test) types)]
|
|
[rf-types (and (eq? ctxt 'test) types)])
|
|
(cond
|
|
[(null? cl*)
|
|
(let ([retcl* (reverse rev-rcl*)])
|
|
(values `(case-lambda ,preinfo ,retcl* ...)
|
|
rret rtypes rt-types rf-types))]
|
|
[else
|
|
(nanopass-case (Lsrc CaseLambdaClause) (car cl*)
|
|
[(clause (,x* ...) ,interface ,body)
|
|
(let-values ([(body ret2 types2 t-types2 f-types2)
|
|
(Expr/main body ctxt types plxc)])
|
|
(let* ([cl2 (with-output-language (Lsrc CaseLambdaClause)
|
|
`(clause (,x* ...) ,interface ,body))]
|
|
[t-types2 (or t-types2 types2)]
|
|
[f-types2 (or f-types2 types2)])
|
|
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
|
|
(cond
|
|
[(predicate-implies? ret2 'bottom)
|
|
(loop (cdr cl*) (cons cl2 rev-rcl*)
|
|
rret rtypes rt-types rf-types)]
|
|
[(predicate-implies? rret 'bottom)
|
|
(loop (cdr cl*) (cons cl2 rev-rcl*)
|
|
ret2 types2 t-types2 f-types2)]
|
|
[else
|
|
(let ([ntypes (pred-env-union/super-base rtypes types
|
|
types2 types
|
|
types
|
|
types)])
|
|
(loop (cdr cl*)
|
|
(cons cl2 rev-rcl*)
|
|
(pred-union rret ret2)
|
|
ntypes
|
|
(cond
|
|
[(not (eq? ctxt 'test))
|
|
#f] ; don't calculate nt-types outside a test context
|
|
[(and (eq? rtypes rt-types)
|
|
(eq? types2 t-types2))
|
|
ntypes] ; don't calculate nt-types when it will be equal to ntypes
|
|
[else
|
|
(pred-env-union/super-base rt-types rtypes
|
|
t-types2 types2
|
|
types
|
|
ntypes)])
|
|
(cond
|
|
[(not (eq? ctxt 'test))
|
|
#f] ; don't calculate nt-types outside a test context
|
|
[(and (eq? rtypes rf-types)
|
|
(eq? types2 f-types2))
|
|
ntypes] ; don't calculate nt-types when it will be equal to ntypes
|
|
[else
|
|
(pred-env-union/super-base rf-types rtypes
|
|
f-types2 types2
|
|
types
|
|
ntypes)])))])))])]))]
|
|
[else
|
|
(let-values ([(ir ret n-types t-types f-types)
|
|
(Expr/main ir 'value outtypes plxc)])
|
|
(values ir
|
|
(if (predicate-implies-not? ret 'procedure)
|
|
'bottom
|
|
#f)
|
|
(pred-env-add/ref (pred-env-intersect/base n-types types outtypes)
|
|
ir 'procedure plxc)
|
|
#f #f))]))
|
|
)
|
|
|
|
(define-pass cptypes : Lsrc (ir ctxt types plxc) -> Lsrc (ret types t-types f-types)
|
|
(Expr : Expr (ir ctxt types plxc) -> Expr (ret types t-types f-types)
|
|
[(quote ,d)
|
|
(values ir (datum->predicate d ir) types #f #f)]
|
|
[(ref ,maybe-src ,x)
|
|
(case ctxt
|
|
[(test)
|
|
(let ([t (pred-env-lookup types x plxc)])
|
|
(cond
|
|
[(predicate-implies? t 'true)
|
|
(values true-rec true-rec types #f #f)]
|
|
[(predicate-implies? t false-rec)
|
|
(values false-rec false-rec types #f #f)]
|
|
[else
|
|
(values ir t
|
|
types
|
|
(pred-env-add/ref types ir 'true plxc) ; don't confuse it with true-rec
|
|
(pred-env-add/ref types ir false-rec plxc))]))]
|
|
[else
|
|
(let ([t (pred-env-lookup types x plxc)])
|
|
(cond
|
|
[(Lsrc? t)
|
|
(nanopass-case (Lsrc Expr) t
|
|
[(quote ,d)
|
|
(values t t types #f #f)]
|
|
[else
|
|
(values ir t types #f #f)])]
|
|
[else
|
|
(values ir (or t 'ptr) types #f #f)]))])] ; In case there is no saved type, use 'ptr to mark it as single valued
|
|
[(seq ,[e1 'effect types plxc -> e1 ret1 types t-types f-types] ,e2)
|
|
(cond
|
|
[(predicate-implies? ret1 'bottom)
|
|
(values e1 'bottom pred-env-bottom #f #f)]
|
|
[else
|
|
(let-values ([(e2 ret types t-types f-types)
|
|
(Expr/main e2 ctxt types plxc)])
|
|
(values (make-seq/no-drop ctxt e1 e2) ret types t-types f-types))])]
|
|
[(if ,[Expr/fix-tf-types : e1 'test types plxc -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3)
|
|
(cond
|
|
[(predicate-implies? ret1 'bottom) ;check bottom first
|
|
(values e1 'bottom pred-env-bottom #f #f)]
|
|
[(predicate-implies? ret1 'true)
|
|
(let-values ([(e2 ret types t-types f-types)
|
|
(Expr/main e2 ctxt types1 plxc)])
|
|
(values (make-seq ctxt e1 e2) ret types t-types f-types))]
|
|
[(predicate-implies? ret1 false-rec)
|
|
(let-values ([(e3 ret types t-types f-types)
|
|
(Expr/main e3 ctxt types1 plxc)])
|
|
(values (make-seq ctxt e1 e3) ret types t-types f-types))]
|
|
[else
|
|
(let-values ([(e2 ret2 types2 t-types2 f-types2)
|
|
(Expr/fix-tf-types e2 ctxt t-types1 plxc)]
|
|
[(e3 ret3 types3 t-types3 f-types3)
|
|
(Expr/fix-tf-types e3 ctxt f-types1 plxc)])
|
|
(let ([ir `(if ,e1 ,e2 ,e3)])
|
|
(cond
|
|
[(and (predicate-implies? ret2 'bottom) ;check bottom first
|
|
(predicate-implies? ret3 'bottom)) ;check bottom first
|
|
(values ir 'bottom pred-env-bottom #f #f)]
|
|
[(predicate-implies? ret2 'bottom) ;check bottom first
|
|
(values (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3)
|
|
ret3 types3 t-types3 f-types3)]
|
|
[(predicate-implies? ret3 'bottom) ;check bottom first
|
|
(values (make-seq ctxt `(if ,e1 ,void-rec ,e3) e2)
|
|
ret2 types2 t-types2 f-types2)]
|
|
[else
|
|
(let ([new-types (pred-env-union/super-base types2 t-types1
|
|
types3 f-types1
|
|
types1
|
|
types1)])
|
|
(values ir
|
|
(pred-union ret2 ret3)
|
|
new-types
|
|
(cond
|
|
[(not (eq? ctxt 'test))
|
|
#f] ; don't calculate t-types outside a test context
|
|
[(and (eq? types2 t-types2)
|
|
(eq? types3 t-types3))
|
|
#f] ; don't calculate t-types when it will be equal to new-types
|
|
[else
|
|
(pred-env-union/super-base t-types2 t-types1
|
|
t-types3 f-types1
|
|
types1
|
|
new-types)])
|
|
(cond
|
|
[(not (eq? ctxt 'test))
|
|
#f] ; don't calculate f-types outside a test context
|
|
[(and (eq? types2 f-types2)
|
|
(eq? types3 f-types3))
|
|
#f] ; don't calculate t-types when it will be equal to new-types
|
|
[else
|
|
(pred-env-union/super-base f-types2 t-types1
|
|
f-types3 f-types1
|
|
types1
|
|
new-types)])))])))])]
|
|
[(set! ,maybe-src ,x ,[e 'value types plxc -> e ret types t-types f-types])
|
|
(values `(set! ,maybe-src ,x ,e) void-rec types #f #f)]
|
|
[(call ,preinfo ,pr ,e* ...)
|
|
(fold-call/primref preinfo pr e* ctxt types plxc)]
|
|
[(case-lambda ,preinfo ,cl* ...)
|
|
(let ([cl* (map (lambda (cl)
|
|
(nanopass-case (Lsrc CaseLambdaClause) cl
|
|
[(clause (,x* ...) ,interface ,body)
|
|
(let-values ([(body ret types t-types f-types)
|
|
(Expr/main body 'value types plxc)])
|
|
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
|
|
(with-output-language (Lsrc CaseLambdaClause)
|
|
`(clause (,x* ...) ,interface ,body)))]))
|
|
cl*)])
|
|
(values `(case-lambda ,preinfo ,cl* ...) 'procedure types #f #f))]
|
|
[(call ,preinfo (case-lambda ,preinfo2 ,cl* ...) ,e* ...)
|
|
(fold-call/lambda preinfo `(case-lambda ,preinfo2 ,cl* ...) e* ctxt types plxc)]
|
|
[(call ,preinfo ,e0 ,e* ...)
|
|
(fold-call/other preinfo e0 e* ctxt types plxc)]
|
|
[(letrec ((,x* ,e*) ...) ,body)
|
|
(let-values ([(ntypes e* r* t* t-t* f-t*)
|
|
(map-Expr/delayed e* types plxc)])
|
|
(let ([ntypes/x (fold-left (lambda (t x p) (pred-env-add t x p plxc)) ntypes x* r*)])
|
|
(let*-values ([(body ret n-types/x t-types/x f-types/x)
|
|
(Expr/main body ctxt ntypes/x plxc)]
|
|
[(n-types t-types f-types)
|
|
(pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)])
|
|
(values `(letrec ([,x* ,e*] ...) ,body)
|
|
ret n-types t-types f-types))))]
|
|
[(letrec* ((,x* ,e*) ...) ,body)
|
|
(let*-values ([(e* ntypes/x)
|
|
(let loop ([x* x*] [e* e*] [types types] [rev-e* '()]) ; this is similar to an ordered-map
|
|
(if (null? x*)
|
|
(values (reverse rev-e*) types)
|
|
(let-values ([(e ret types t-types f-types)
|
|
(Expr/main (car e*) 'value types plxc)])
|
|
(let ([types (pred-env-add types (car x*) ret plxc)])
|
|
(loop (cdr x*) (cdr e*) types (cons e rev-e*))))))]
|
|
[(body ret n-types/x t-types/x f-types/x)
|
|
(Expr/main body ctxt ntypes/x plxc)]
|
|
[(n-types t-types f-types)
|
|
(pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt types plxc)])
|
|
(values `(letrec* ([,x* ,e*] ...) ,body)
|
|
ret n-types t-types f-types))]
|
|
[,pr
|
|
(values ir
|
|
(and (all-set? (prim-mask proc) (primref-flags pr)) 'procedure)
|
|
types #f #f)]
|
|
[(foreign (,conv* ...) ,name ,[e 'value types plxc -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
|
|
(values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
|
#f types #f #f)]
|
|
[(fcallable (,conv* ...) ,[e 'value types plxc -> e ret types t-types f-types] (,arg-type* ...) ,result-type)
|
|
(values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
|
|
#f types #f #f)]
|
|
[(record ,rtd ,[rtd-expr 'value types plxc -> rtd-expr ret-re types-re t-types-re f-types-re]
|
|
,[e* 'value types plxc -> e* r* t* t-t* f-t*] ...)
|
|
(values `(record ,rtd ,rtd-expr ,e* ...)
|
|
(rtd->record-predicate rtd-expr #t)
|
|
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
|
|
#f #f)]
|
|
[(record-ref ,rtd ,type ,index ,[e 'value types plxc -> e ret types t-types f-types])
|
|
(values `(record-ref ,rtd ,type ,index ,e)
|
|
#f
|
|
(pred-env-add/ref types e '$record plxc)
|
|
#f #f)]
|
|
[(record-set! ,rtd ,type ,index ,[e1 'value types plxc -> e1 ret1 types1 t-types1 f-types1]
|
|
,[e2 'value types plxc -> e2 ret2 types2 t-types2 f-types2])
|
|
(values `(record-set! ,rtd ,type ,index ,e1 ,e2)
|
|
void-rec
|
|
(pred-env-add/ref (pred-env-intersect/base types1 types2 types)
|
|
e1 '$record plxc)
|
|
#f #f)]
|
|
[(record-type ,rtd ,[e 'value types plxc -> e ret types t-types f-types])
|
|
(values `(record-type ,rtd ,e)
|
|
#f types #f #f)]
|
|
[(record-cd ,rcd ,rtd-expr ,[e 'value types plxc -> e ret types t-types f-types])
|
|
(values `(record-cd ,rcd ,rtd-expr ,e)
|
|
#f types #f #f)]
|
|
[(immutable-list (,[e* 'value types plxc -> e* r* t* t-t* f-t*] ...)
|
|
,[e 'value types plxc -> e ret types t-types f-types])
|
|
(values `(immutable-list (,e* ...) ,e)
|
|
ret types #f #f)]
|
|
[(moi) (values ir #f types #f #f)]
|
|
[(pariah) (values ir void-rec types #f #f)]
|
|
[(cte-optimization-loc ,box ,[e 'value types plxc -> e ret types t-types f-types] ,exts)
|
|
(values `(cte-optimization-loc ,box ,e ,exts)
|
|
ret types #f #f)]
|
|
[(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)]
|
|
[(profile ,src) (values ir #f types #f #f)]
|
|
[else ($oops who "unrecognized record ~s" ir)])
|
|
|
|
; body of cptypes
|
|
(Expr ir ctxt types plxc)
|
|
|
|
)
|
|
|
|
; friendly name to use in other internal functions
|
|
; so it is similar to Expr/call and Expr/fix-tf-types
|
|
(define Expr/main cptypes)
|
|
|
|
; external version of cptypes: Lsrc -> Lsrc
|
|
(define (Scptypes ir)
|
|
(let-values ([(ir ret types t-types f-types)
|
|
(Expr/main ir 'value pred-env-empty (box 0))])
|
|
ir))
|
|
|
|
(set! $cptypes Scptypes)
|
|
)
|
|
|
|
; check to make sure all required handlers were seen, after expansion of the
|
|
; expression above has been completed
|
|
(let ()
|
|
(define-syntax (test-handlers sxt)
|
|
(for-each
|
|
(lambda (sym)
|
|
(let ([flags ($sgetprop sym '*flags* 0)])
|
|
(when (all-set? (prim-mask cptypes2) flags)
|
|
; currently all the flags use the same bit
|
|
(let ([used (map (lambda (key) (and (getprop sym key #f)
|
|
(begin (remprop sym 'cp02) #t)))
|
|
'(cptypes2 cptypes3 cptypes2x cptypes3x))])
|
|
(when (andmap not used)
|
|
($oops 'çptypes "no cptypes handler for ~s" sym))))))
|
|
(oblist))
|
|
#'(void))
|
|
(test-handlers)
|
|
)
|