Skip to content

Instantly share code, notes, and snippets.

@akeep

akeep/cptypes.ss.diff

Created May 24, 2018 00:42
Show Gist options
  • Save akeep/37db1369a87bfdf7cd55aaba2619446c to your computer and use it in GitHub Desktop.
Save akeep/37db1369a87bfdf7cd55aaba2619446c to your computer and use it in GitHub Desktop.
Download ZIP
Updated cptypes.ss
Raw
cptypes.ss.diff
65c65
< (define $cptypes
---
> (define $cptypes)
70a71,72
> (define-pass cptypes : Lsrc (ir) -> Lsrc ()
> (definitions
77c79
< (let ([k (eq-hashtable-ref known (prelex-operand x) #f)])
---
> (let ([k (eq-hashtable-ref known (car (prelex-operand x)) #f)])
81c83
< (printf "matting !!! [cptypes] duplicated prelex counter with ~s and ~s [~s] ~s" x k (prelex-operand x) count)
---
> (printf "matting !!! [cptypes] duplicated prelex counter with ~s and ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x k (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id))
83c85
< ($impoops 'cptypes "duplicated prelex counter with ~s and ~s [~s] ~s" x k (prelex-operand x) count))
---
> ($impoops 'cptypes "duplicated prelex counter with ~s and ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x k (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id)))
86c88
< (printf "matting !!! [cptypes] unexpected prelex counter with ~s [~s] ~s" x (prelex-operand x) count)
---
> (printf "matting !!! [cptypes] unexpected prelex counter with ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id))
88,89c90,92
< ($impoops 'cptypes "unexpected prelex counter with ~s [~s] ~s" x (prelex-operand x) count)))))
< (or (prelex-operand x)
---
> ($impoops 'cptypes "unexpected prelex counter with ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id))))))
> (or (let ([p (prelex-operand x)])
> (and p (car p)))
92c95
< (prelex-operand-set! x c)
---
> (prelex-operand-set! x (cons c (get-thread-id)))
639,640c642
<
< (define-pass cptypes : Lsrc (ir ctxt types) -> Lsrc (ret types t-types f-types)
---
> )
675c677
< (cptypes e2 ctxt types)])
---
> (Expr e2 ctxt types)])
683c685
< (cptypes e2 ctxt types1)])
---
> (Expr e2 ctxt types1)])
687c689
< (cptypes e3 ctxt types1)])
---
> (Expr e3 ctxt types1)])
693c695
< (cptypes e2 ctxt t-types1)]
---
> (Expr e2 ctxt t-types1)]
697c699
< (cptypes e3 ctxt f-types1)]
---
> (Expr e3 ctxt f-types1)]
908c910
< (cptypes body 'value types)])
---
> (Expr body 'value types)])
934c936
< (cptypes body ctxt t)])
---
> (Expr body ctxt t)])
974c976
< (cptypes body ctxt t)])
---
> (Expr body ctxt t)])
993c995
< (cptypes (car e*) 'value types)])
---
> (Expr (car e*) 'value types)])
997c999
< (cptypes body ctxt types)])
---
> (Expr body ctxt types)])
1056,1058d1057
< (Expr ir ctxt types))
<
< (lambda (ir)
1060c1059
< (cptypes ir 'value pred-env-empty)])
---
> (Expr ir 'value pred-env-empty)])
1062c1061,1064
< ))
---
>
> (set! $cptypes cptypes)
>
> )
Raw
gistfile1.txt
"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)))
+ 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-pass cptypes : Lsrc (ir) -> Lsrc ()
(definitions
(define prelex-counter
(let ()
(define count 0)
(define known (make-eq-hashtable))
(lambda (x)
(when (prelex-operand x)
(let ([k (eq-hashtable-ref known (car (prelex-operand x)) #f)])
(if k
(unless (eq? x k)
(newline)
(printf "matting !!! [cptypes] duplicated prelex counter with ~s and ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x k (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id))
(newline)
($impoops 'cptypes "duplicated prelex counter with ~s and ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x k (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id)))
(begin
(newline)
(printf "matting !!! [cptypes] unexpected prelex counter with ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id))
(newline)
($impoops 'cptypes "unexpected prelex counter with ~s [~s (on thread: ~s)] ~s (on thread: ~s)" x (car (prelex-operand x)) (cdr (prelex-operand x)) count (get-thread-id))))))
(or (let ([p (prelex-operand x)])
(and p (car p)))
(let ([c count])
(set! count (fx+ count 1))
(prelex-operand-set! x (cons c (get-thread-id)))
(eq-hashtable-set! known c x)
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))
(define (simple? e) ; Simplified version copied from cp0. TODO: copy the rest.
(nanopass-case (Lsrc Expr) e
[(quote ,d) #t]
[(ref ,maybe-src ,x) #t]
[(case-lambda ,preinfo ,cl* ...) #t]
[,pr #t]
[(moi) #t]
[(record-type ,rtd ,e) (simple? e)]
[else #f]
#;[else ($oops who "unrecognized record ~s" e)]))
; TODO: Remove discardable operations in e1. (vector (f) (g)) => (begin (f) (g))
(define make-seq
; ensures that the right subtree of the output seq is not a seq if the
; second argument is similarly constrained, to facilitate result-exp
(lambda (ctxt e1 e2)
(if (simple? e1)
e2
(if (and (eq? ctxt 'effect) (simple? e2))
e1
(let ([e1 (nanopass-case (Lsrc Expr) e1
[(seq ,e11 ,e12)
(guard (simple? e12))
e11]
[else e1])])
(nanopass-case (Lsrc Expr) e2
[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
[else `(seq ,e1 ,e2)]))))))
#;(define make-seq* ; requires at least one operand
(lambda (ctxt e*)
(if (null? (cdr e*))
(car e*)
(make-seq ctxt (car e*) (make-seq* ctxt (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-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)
(define pred-env-empty empty-fxmap)
(define (pred-env-add/key types key pred)
(cond
[(and pred
(not (eq? pred 'ptr))) ; filter 'ptr to reduce the size
(let ([old (fxmap-ref types key #f)])
(cond
[(not old)
(fxmap-set types key pred)]
[else (let ([new (pred-intersect old pred)])
(if (eq? old new)
types
(fxmap-set types key new)))]))]
[else
types]))
(define (pred-env-add types x pred)
(cond
[(and x (not (prelex-assigned x)))
(pred-env-add/key types (prelex-counter x) pred)]
[else types]))
(define (pred-env-remove/base types x base)
(fxmap-remove/base types (prelex-counter x) base))
(define (pred-env-lookup types x)
(and (not (prelex-assigned x))
(fxmap-ref types (prelex-counter x) #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
[(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) (error 'pred-env-intersect/base "") (void))
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
(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) (error 'pred-env-union/base "") (void))
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 to minimize the amount of operations
; required. In particular, base should be the base of types/b and from/b.
(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)])
(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 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)
(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) (error 'pred-env-rebase "") (void))
new-base
base)
ret))
)
(define (pred-env-add/ref types r pred)
(nanopass-case (Lsrc Expr) r
[(ref ,maybe-src ,x)
(pred-env-add types x pred)]
[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 (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)
(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)]
[else '$record])]
[else '$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]
[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.
; 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]
[symbol 'symbol]
[char 'char]
[bottom 'bottom] ;pseudo-predicate
[ptr 'ptr] ;pseudo-predicate
[boolean 'boolean]
[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)]
[else '(bottom . ptr)]))])) ; this is used only to analyze the signatures.
(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?)]
[(symbol) (or (eq? x 'gensym)
(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 (signature->result-predicate signature)
(let ([results (cdr signature)])
(and (fx= (length results) 1)
(let ([result (car results)])
(cond
[(symbol? result)
(primref-name/nqm->predicate result #t)]
[(equal? result '(ptr . ptr))
'pair]
[(pair? result)
'pair]
[else
'ptr])))))
(define primref->result-predicate/cache (make-hashtable equal-hash equal?))
(define (primref->result-predicate pr)
(let ([key (primref-name pr)])
(if (hashtable-contains? primref->result-predicate/cache key)
(hashtable-ref primref->result-predicate/cache key #f)
(let ([new (primref->result-predicate/no-cache pr)])
(hashtable-set! primref->result-predicate/cache key new)
new))))
(define (primref->result-predicate/no-cache pr)
(let ([pred/flags
(let ([flags (primref-flags pr)])
(cond
[(all-set? (prim-mask abort-op) flags)
'bottom]
[(all-set? (prim-mask true) flags)
'true]
[(all-set? (prim-mask boolean-valued) flags)
'boolean]
[else
#f]))]
[pred/signatures
(let ([signatures (primref-signatures pr)])
(and (not (null? signatures))
(let ([results (map (lambda (s) (signature->result-predicate s)) signatures)])
(fold-left pred-union 'bottom results))))])
(pred-intersect pred/flags pred/signatures)))
(define (signature->argument-predicate signature pos extend?)
(let* ([arguments (car signature)]
[dots (memq '... arguments)])
(cond
[(and dots (null? (cdr dots)))
(cond
[(< pos (- (length arguments) 2))
(primref-name/nqm->predicate (list-ref arguments pos) extend?)]
[else
(primref-name/nqm->predicate (list-ref arguments (- (length arguments) 2)) extend?)])]
[dots #f] ; TODO: Extend to handle this case, perhaps knowing the argument count.
[else
(cond
[(< pos (length arguments))
(let ([argument (list-ref arguments pos)])
(cond
[(equal? argument '(ptr . ptr))
'pair]
[(and extend? (pair? argument))
'pair]
[else
(primref-name/nqm->predicate argument extend?)]))]
[else
'bottom])])))
(define primref->argument-predicate/cache (make-hashtable equal-hash equal?))
(define (primref->argument-predicate pr pos extend?)
(let ([key (list (primref-name pr) pos extend?)])
(if (hashtable-contains? primref->argument-predicate/cache key)
(hashtable-ref primref->argument-predicate/cache key #f)
(let ([new (primref->argument-predicate/no-cache pr pos extend?)])
(when (<= pos 10)
(hashtable-set! primref->argument-predicate/cache key new))
new))))
(define (primref->argument-predicate/no-cache pr pos extend?)
(let ([signatures (primref-signatures pr)])
(and (>= (length signatures) 1)
(let ([vals (map (lambda (signature)
(signature->argument-predicate signature pos extend?))
signatures)])
(fold-left (if extend? pred-union pred-intersect) (car vals) (cdr vals))))))
(define (primref->unsafe-primref pr)
(lookup-primref 3 (primref-name pr)))
)
(Expr : Expr (ir ctxt types) -> 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)])
(cond
[(predicate-implies-not? t false-rec)
(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) ; don't confuse it with true-rec
(pred-env-add/ref types ir false-rec))]))]
[else
(let ([t (pred-env-lookup types x)])
(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 t types #f #f)]))])]
[(seq ,[e1 'effect types -> e1 ret1 types t-types f-types] ,e2)
(cond
[(predicate-implies? ret1 'bottom)
(values e1 ret1 types #f #f)]
[else
(let-values ([(e2 ret types t-types f-types)
(Expr e2 ctxt types)])
(values (make-seq ctxt e1 e2) ret types t-types f-types))])]
[(if ,[e1 'test types -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3)
(cond
[(predicate-implies? ret1 'bottom) ;check bottom first
(values e1 ret1 types #f #f)]
[(predicate-implies-not? ret1 false-rec)
(let-values ([(e2 ret types t-types f-types)
(Expr e2 ctxt types1)])
(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 e3 ctxt types1)])
(values (make-seq ctxt e1 e3) ret types t-types f-types))]
[else
(let*-values ([(t-types1) (or t-types1 types1)]
[(f-types1) (or f-types1 types1)]
[(e2 ret2 types2 t-types2 f-types2)
(Expr e2 ctxt t-types1)]
[(t-types2) (or t-types2 types2)]
[(f-types2) (or f-types2 types2)]
[(e3 ret3 types3 t-types3 f-types3)
(Expr e3 ctxt f-types1)]
[(t-types3) (or t-types3 types3)]
[(f-types3) (or f-types3 types3)])
(let ([ir `(if ,e1 ,e2 ,e3)])
(cond
[(predicate-implies? ret2 'bottom) ;check bottom first
(values ir ret3 types3 t-types3 f-types3)]
[(predicate-implies? ret3 'bottom) ;check bottom first
(values ir 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
(cond
[(and (eq? ctxt 'test)
(predicate-implies-not? ret2 false-rec)
(predicate-implies-not? ret3 false-rec))
true-rec]
[else
(pred-union ret2 ret3)])
new-types
(cond
[(not (eq? ctxt 'test))
#f] ; don't calculate t-types outside a test context
[(predicate-implies? ret2 false-rec)
(pred-env-rebase t-types3 types1 new-types)]
[(predicate-implies? ret3 false-rec)
(pred-env-rebase t-types2 types1 new-types)]
[(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
[(predicate-implies-not? ret2 false-rec)
(pred-env-rebase f-types3 types1 new-types)]
[(predicate-implies-not? ret3 false-rec)
(pred-env-rebase f-types2 types1 new-types)]
[(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 -> e ret types t-types f-types])
(values `(set! ,maybe-src ,x ,e) void-rec types #f #f)]
[(call ,preinfo ,pr ,[e* 'value types -> e* r* t* t-t* f-t*] ...)
(let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
[ret (primref->result-predicate pr)])
(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 #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)))))])
(cond
[(predicate-implies? ret 'bottom)
(values `(call ,preinfo ,pr ,e* ...) ret t #f #f)]
[(not (arity-okay? (primref-arity pr) (length e*)))
(values `(call ,preinfo ,pr ,e* ...) 'bottom t #f #f)]
[(and (fx= (length e*) 2)
(or (eq? (primref-name pr) 'eq?)
(eq? (primref-name pr) 'eqv?)))
(let ([r1 (car r*)]
[r2 (cadr r*)]
[e1 (car e*)]
[e2 (cadr e*)])
(cond
[(or (predicate-implies-not? r1 r2)
(predicate-implies-not? r2 r1))
(values (make-seq ctxt (make-seq 'effect e1 e2) false-rec)
false-rec t #f #f)]
[else
(values `(call ,preinfo ,pr ,e* ...)
ret
types
(and (eq? ctxt 'test)
(pred-env-add/ref
(pred-env-add/ref t e1 r2)
e2 r1))
#f)]))]
[(and (fx= (length e*) 1)
(primref->predicate pr #t))
(let ([var (car r*)]
[pred (primref->predicate pr #f)])
(cond
[(predicate-implies? var pred)
(values (make-seq ctxt (car e*) true-rec)
true-rec t #f #f)]
[else
(let ([pred (primref->predicate pr #t)])
(cond
[(predicate-implies-not? var pred)
(values (make-seq ctxt (car e*) false-rec)
false-rec t #f #f)]
[else
(values `(call ,preinfo ,pr ,e* ...)
ret
types
(and (eq? ctxt 'test)
(pred-env-add/ref t (car e*) pred))
#f)]))]))]
[(and (fx>= (length e*) 1)
(eq? (primref-name pr) '$record))
(values `(call ,preinfo ,pr ,e* ...) (rtd->record-predicate (car e*)) t #f #f)]
[(and (fx= (length e*) 2)
(or (eq? (primref-name pr) 'record?)
(eq? (primref-name pr) '$sealed-record?)))
(let ([pred (rtd->record-predicate (cadr e*))]
[var (car r*)])
(cond
[(predicate-implies-not? var pred)
(cond
[(or (all-set? (prim-mask unsafe) (primref-flags pr))
(nanopass-case (Lsrc Expr) (cadr e*) ; ensure that it is actually a rtd
[(quote ,d)
(record-type-descriptor? d)]
[(record-type ,rtd ,e) #t]
[else #f]))
(values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) false-rec)
false-rec t #f #f)]
[else
(values (make-seq ctxt ir false-rec)
false-rec t #f #f)])]
[(and (not (eq? pred '$record)) ; assume that the only extension is '$record
(predicate-implies? var pred))
(values (make-seq ctxt (make-seq 'effect (car e*) (cadr e*)) true-rec)
true-rec t #f #f)]
[(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
(nanopass-case (Lsrc Expr) (cadr e*) ; check that it is a rtd
[(quote ,d)
(record-type-descriptor? d)]
[(record-type ,rtd ,e) #t]
[else #f]))
(let ([pr (primref->unsafe-primref pr)])
(values `(call ,preinfo ,pr ,e* ...)
ret types
(and (eq? ctxt 'test)
(pred-env-add/ref types (car e*) pred))
#f))]
[else
(values `(call ,preinfo ,pr ,e* ...)
ret
types
(and (eq? ctxt 'test)
(pred-env-add/ref types (car e*) pred))
#f)]))]
; TODO: special case for call-with-values.
[(and (fx= (length e*) 1)
(eq? (primref-name pr) 'exact?))
(cond
[(predicate-implies? (car r*) 'exact-integer)
(values (make-seq ctxt (car e*) true-rec)
true-rec t #f #f)]
[(predicate-implies? (car r*) 'flonum)
(values (make-seq ctxt (car e*) false-rec)
false-rec t #f #f)]
[(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
(predicate-implies? (car r*) 'number))
(let ([pr (primref->unsafe-primref pr)])
(values `(call ,preinfo ,pr ,e* ...)
ret t #f #f))]
[else
(values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])]
[(and (fx= (length e*) 1)
(eq? (primref-name pr) 'inexact?))
(cond
[(predicate-implies? (car r*) 'exact-integer)
(values (make-seq ctxt (car e*) false-rec)
false-rec t #f #f)]
[(predicate-implies? (car r*) 'flonum)
(values (make-seq ctxt (car e*) true-rec)
true-rec t #f #f)]
[(and (not (all-set? (prim-mask unsafe) (primref-flags pr)))
(predicate-implies? (car r*) 'number))
(let ([pr (primref->unsafe-primref pr)])
(values `(call ,preinfo ,pr ,e* ...)
ret t #f #f))]
[else
(values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])]
[(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 #f)))
r* (enumerate r*)))
(let ([pr (primref->unsafe-primref pr)])
(values `(call ,preinfo ,pr ,e* ...)
ret types #f #f))]
[else
(values `(call ,preinfo ,pr ,e* ...) ret t #f #f)])))]
[(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 body 'value types)])
(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 (clause (,x** ...) ,interface* ,body*) ...)
,[e* 'value types -> e* r* t* t-t* f-t*] ...)
;; pulled from cpnanopass
(define find-matching-clause
(lambda (len x** interface* body* kfixed kvariable kfail)
(let f ([x** x**] [interface* interface*] [body* body*])
(if (null? interface*)
(kfail)
(let ([interface (car interface*)])
(if (fx< interface 0)
(let ([nfixed (fxlognot interface)])
(if (fx>= len nfixed)
(kvariable nfixed (car x**) (car body*))
(f (cdr x**) (cdr interface*) (cdr body*))))
(if (fx= interface len)
(kfixed (car x**) (car body*))
(f (cdr x**) (cdr interface*) (cdr body*)))))))))
(define finish
(lambda (x* interface body t)
(let-values ([(body ret n-types t-types f-types)
(Expr body ctxt t)])
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
[t-types (and (eq? ctxt 'test)
t-types
(not (eq? n-types t-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
[f-types (and (eq? ctxt 'test)
f-types
(not (eq? n-types f-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
(values
`(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...)
ret new-types t-types f-types)))))
(let ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
[len (length e*)])
(find-matching-clause (length e*) x** interface* body*
(lambda (x* body) (finish x* len body (fold-left pred-env-add t x* r*)))
(lambda (nfixed x* body)
(finish x* (fxlognot nfixed) body
(fold-left pred-env-add t x*
(let f ([i nfixed] [r* r*])
(if (fx= i 0)
(list (if (null? r*) 'null 'pair))
(cons (car r*) (f (fx- i 1) (cdr r*))))))))
(lambda () (values ir 'bottom types #f #f))))]
[(call ,preinfo ,[e0 'value types -> e0 ret0 types0 t-types0 f-types0]
,[e* 'value types -> e* r* t* t-t* f-t*] ...)
(values `(call ,preinfo ,e0 ,e* ...)
#f
(pred-env-add/ref
(pred-env-intersect/base
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
types0 types)
e0 'procedure)
#f #f)]
[(letrec ((,x* ,[e* 'value types -> e* r* t* t-t* t-f*]) ...) ,body)
(let* ([t (fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)]
[t (fold-left pred-env-add t x* r*)])
(let-values ([(body ret n-types t-types f-types)
(Expr body ctxt t)])
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
[t-types (and (eq? ctxt 'test)
t-types
(not (eq? n-types t-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
[f-types (and (eq? ctxt 'test)
f-types
(not (eq? n-types f-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
(values `(letrec ([,x* ,e*] ...) ,body)
ret new-types t-types f-types))))]
[(letrec* ((,x* ,e*) ...) ,body)
(let*-values ([(e* types)
(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 (car e*) 'value types)])
(let ([types (pred-env-add types (car x*) ret)])
(loop (cdr x*) (cdr e*) types (cons e rev-e*))))))])
(let-values ([(body ret n-types t-types f-types)
(Expr body ctxt types)])
(let* ([new-types (fold-left (lambda (f x) (pred-env-remove/base f x types)) n-types x*)]
[t-types (and (eq? ctxt 'test)
t-types
(not (eq? n-types t-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) t-types x*))]
[f-types (and (eq? ctxt 'test)
f-types
(not (eq? n-types f-types))
(fold-left (lambda (f x) (pred-env-remove/base f x new-types)) f-types x*))])
(for-each (lambda (x) (prelex-operand-set! x #f)) x*)
(values `(letrec* ([,x* ,e*] ...) ,body)
ret new-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 -> 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 -> 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 -> rtd-expr ret-re types-re t-types-re f-types-re]
,[e* 'value types -> e* r* t* t-t* f-t*] ...)
(values `(record ,rtd ,rtd-expr ,e* ...)
(rtd->record-predicate rtd-expr)
(fold-left (lambda (f x) (pred-env-intersect/base f x types)) types t*)
#f #f)]
[(record-ref ,rtd ,type ,index ,[e 'value types -> e ret types t-types f-types])
(values `(record-ref ,rtd ,type ,index ,e)
#f
(pred-env-add/ref types e '$record)
#f #f)]
[(record-set! ,rtd ,type ,index ,[e1 'value types -> e1 ret1 types1 t-types1 f-types1]
,[e2 'value types -> 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)
#f #f)]
[(record-type ,rtd ,[e 'value types -> e ret types t-types f-types])
(values `(record-type ,rtd ,e)
#f types #f #f)]
[(record-cd ,rcd ,rtd-expr ,[e 'value types -> e ret types t-types f-types])
(values `(record-cd ,rcd ,rtd-expr ,e)
#f types #f #f)]
[(immutable-list (,[e* 'value types -> e* r* t* t-t* f-t*] ...)
,[e 'value types -> 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 -> e ret types t-types f-types])
(values `(cte-optimization-loc ,box ,e)
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)])
(let-values ([(ir ret types t-types f-types)
(Expr ir 'value pred-env-empty)])
ir))
(set! $cptypes cptypes)
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment