Skip to content

Commit

Permalink
Chez Scheme: move info about predicates from cptypes to primdata
Browse files Browse the repository at this point in the history 
Also, don't assume predicates are total and fix the type of ports.
  • Loading branch information
@gus-massa @mflatt
gus-massa authored and mflatt committed Apr 10, 2022
1 parent abde0af commit 41e7ab8
Show file tree
Hide file tree
Showing 7 changed files with 103 additions and 187 deletions.
5 changes: 3 additions & 2 deletions mats/primvars.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -300,13 +300,14 @@
[((in ...) ...) #`(((in ...) #,outs) ...)])))
(define do-entry
(lambda (x)
(syntax-case x (feature sig flags ->)
(syntax-case x (feature sig pred flags ->)
[(prim [feature f] . more)
(if (memq (datum f) feature*)
(do-entry #'(prim . more))
#'(void))]
[(prim [flags flag ...]) (do-entry #'(prim [sig] [flags flag ...]))]
[(prim [sig [(in ...) ... -> (out ...)] ...] [flags flag ...])
[(prim [sig sigs ...] [flags flag ...]) (do-entry #'(prim [sig sigs ...] [pred #f] [flags flag ...]))]
[(prim [sig [(in ...) ... -> (out ...)] ...] [pred p] [flags flag ...])
(with-syntax ([(unprefixed . prim) (prim-name #'prim)])
(with-syntax ([((((in ...) (out ...)) ...) ...)
(map ins-and-outs #'(((in ...) ...) ...) #'((out ...) ...))])
Expand Down
3 changes: 2 additions & 1 deletion rktboot/primdata.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -68,7 +68,8 @@
(define-values (flags sigs)
(for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)])
(match spec
[`[sig ,sigs ...] (values flags sigs )]
[`[sig ,sigs ...] (values flags sigs)]
[`[pred ,pred] (values flags sigs)]
[`[flags ,flags ...] (values (append flags group-flags) sigs)]
[`[feature ,features ...] (values flags sigs)])))
(define plain-id (if (pair? id)
Expand Down
26 changes: 19 additions & 7 deletions s/cptypes-lattice.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -65,10 +65,6 @@
flonum-pred
real-pred
number-pred
exact-pred
inexact-pred
integer-pred
flinteger-pred
flzero-pred
$fixmediate-pred
$list-pred ; immutable lists
Expand Down Expand Up @@ -201,6 +197,7 @@
number*-pred real*-pred ratnum-pred
flonum-pred flinteger-pred flzero-pred
exact*-pred inexact-pred
exact-complex-pred inexact-complex-pred
char-pred
symbol-pred interned-symbol-pred uninterned-symbol-pred gensym-pred)

Expand Down Expand Up @@ -262,6 +259,8 @@
(define flzero-pred (make-pred-multiplet flzero-mask))
(define exact*-pred (make-pred-multiplet exact*-pred-mask))
(define inexact-pred (make-pred-multiplet inexact-pred-mask))
(define exact-complex-pred (make-pred-multiplet exact-complex-mask))
(define inexact-complex-pred (make-pred-multiplet inexact-complex-mask))
(define char-pred (make-pred-multiplet char-mask))
(define symbol-pred (make-pred-multiplet symbol-pred-mask))
(define interned-symbol-pred (make-pred-multiplet interned-symbol-mask))
Expand Down Expand Up @@ -292,6 +291,7 @@
(define maybe-bytevector-pred (make-pred-or false-rec 'bottom 'bytevector 'bottom 'bottom))
(define eof/bytevector-pred (make-pred-or eof-rec 'bottom 'bytevector 'bottom 'bottom))
(define maybe-pair-pred (make-pred-or false-rec 'bottom 'pair 'bottom 'bottom))
(define maybe-port-pred (make-pred-or false-rec 'bottom 'port 'bottom 'bottom))
(define maybe-symbol/string-pred (make-pred-or false-rec symbol-pred 'string 'bottom 'bottom))
(define maybe-$record-pred (make-pred-or false-rec 'bottom 'bottom 'bottom '$record))
(define maybe-char-pred (make-pred-or false-rec char-pred 'bottom 'bottom 'bottom))
Expand Down Expand Up @@ -466,17 +466,29 @@
[rational (cons 'exact-integer real-pred)]
[integer integer-pred]
[(uinteger sub-integer) (cons 'bottom integer-pred)]
[(cflonum inexact-number) inexact-pred]
[inexact-number inexact-pred]
[exact-number exact-pred]
[$inexactnum inexact-complex-pred]
[$exactnum exact-complex-pred]
[integer integer-pred]
[flinteger flinteger-pred]
[number number-pred]
[sub-number (cons 'bottom number-pred)]
[maybe-number maybe-number-pred]

[port 'port]
[(textual-input-port textual-output-port textual-port
binary-input-port binary-output-port binary-port
input-port output-port file-port) '(bottom . port)]
[(sub-port) '(bottom . normalptr)]
[(maybe-textual-input-port maybe-textual-output-port
maybe-binary-input-port maybe-binary-output-port) (cons false-rec maybe-port-pred)]

[$record '$record]
[(record rtd) '(bottom . $record)] ; not sealed
[(maybe-rtd) (cons false-rec maybe-$record-pred)]
[(transcoder textual-input-port textual-output-port binary-input-port binary-output-port) '(bottom . $record)] ; opaque
[(maybe-transcoder maybe-textual-input-port maybe-textual-output-port maybe-binary-input-port maybe-binary-output-port input-port output-port) (cons false-rec maybe-$record-pred)]
[(transcoder) '(bottom . $record)] ; opaque, sealed
[(maybe-transcoder) (cons false-rec maybe-$record-pred)]
[(rcd sfd timeout) '(bottom . $record)] ; not opaque, sealed
[(maybe-rcd maybe-sub-rcd maybe-sfd maybe-timeout) (cons false-rec maybe-$record-pred)]

Expand Down
144 changes: 20 additions & 124 deletions s/cptypes.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -573,7 +573,6 @@ Notes:
(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]
[(list? d) '$list-pair] ; quoted list should not be modified.
[(pair? d) 'pair]
[(box? d) 'box]
Expand Down Expand Up @@ -602,48 +601,6 @@ Notes:
[else (if (not extend?) 'bottom '$record)])]
[else (if (not extend?) 'bottom '$record)]))

; Recognize predicates and get the corresponding
; type using the notation in primdata.ss
; TODO: Move this info to primdata.ss
(define (primref-name->predicate name)
(case name
[pair? 'pair]
[box? 'box]
[$record? '$record]
[fixnum? 'fixnum]
[bignum? 'bignum]
[ratnum? 'ratnum]
[flonum? 'flonum]
[real? 'real]
[number? 'number]
[vector? 'vector]
[string? 'string]
[bytevector? 'bytevector]
[fxvector? 'fxvector]
[flvector? 'flvector]
[gensym? 'gensym]
[uninterned-symbol? 'uninterned-symbol]
[symbol? 'symbol]
[char? 'char]
[boolean? 'boolean]
[procedure? 'procedure]
[not 'false]
[null? 'null]
[eof-object? 'eof-object]
[bwp-object? 'bwp-object]
[$immediate? '$immediate]
[list? 'list]
[list-assuming-immutable? 'list-assuming-immutable]
[record? 'record]
[record-type-descriptor? 'rtd]
[integer? 'integer]
[rational? 'rational]
[cflonum? 'cflonum]
[else #f])) ; this function is used only to detect predicates.

(define (primref->predicate pr extend?)
(primref-name/nqm->predicate (primref-name->predicate (primref-name pr)) extend?))

(define check-constant-is?
(case-lambda
[(x)
Expand Down Expand Up @@ -695,6 +652,10 @@ Notes:
(let ([rest ($sgetprop (primref-name pr) '*rest-type* #f)])
(primref-name/nqm->predicate rest extend?))]))]))))

(define (primref->predicate pr extend?)
(let ([type ($sgetprop (primref-name pr) '*pred-type* #f)])
(primref-name/nqm->predicate type extend?)))

(define (primref->unsafe-primref pr)
(lookup-primref 3 (primref-name pr)))

Expand Down Expand Up @@ -1163,76 +1124,6 @@ Notes:
(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-pred)
(values (make-seq ctxt n true-rec)
true-rec ntypes #f #f)]
[(predicate-disjoint? r exact-pred)
(values (make-seq ctxt n false-rec)
false-rec ntypes #f #f)]
[else
(values `(call ,preinfo ,pr ,n)
ret
ntypes
(pred-env-add/ref ntypes n exact-pred plxc)
(pred-env-add/not/ref ntypes n exact-pred plxc))]))])

(define-specialize 2 inexact?
[(n) (let ([r (get-type n)])
(cond
[(predicate-implies? r inexact-pred)
(values (make-seq ctxt n true-rec)
true-rec ntypes #f #f)]
[(predicate-disjoint? r inexact-pred)
(values (make-seq ctxt n false-rec)
false-rec ntypes #f #f)]
[else
(values `(call ,preinfo ,pr ,n)
ret
ntypes
(pred-env-add/ref ntypes n inexact-pred plxc)
(pred-env-add/not/ref ntypes n inexact-pred plxc))]))])

(define-specialize 2 integer?
[(n) (let ([r (get-type n)])
(cond
[(predicate-implies? r integer-pred)
(values (make-seq ctxt n true-rec)
true-rec ntypes #f #f)]
[(predicate-disjoint? r integer-pred)
(values (make-seq ctxt n false-rec)
false-rec ntypes #f #f)]
[(predicate-implies? r flonum-pred)
(values `(call ,preinfo ,(lookup-primref 3 'flinteger?) ,n)
ret
ntypes
(pred-env-add/ref ntypes n flinteger-pred plxc)
(pred-env-add/not/ref ntypes n flinteger-pred plxc))]
[else
(values `(call ,preinfo ,pr ,n)
ret
ntypes
(pred-env-add/ref ntypes n integer-pred plxc)
(pred-env-add/not/ref ntypes n integer-pred plxc))]))])

(define-specialize 2 flinteger?
[(n) (let ([r (get-type n)])
(cond
[(predicate-implies? r flinteger-pred)
(values (make-seq ctxt n true-rec)
true-rec ntypes #f #f)]
[(predicate-disjoint? r flinteger-pred)
(values (make-seq ctxt n false-rec)
false-rec ntypes #f #f)]
[else
(values `(call ,preinfo ,pr ,n)
ret
ntypes
(pred-env-add/ref ntypes n flinteger-pred plxc)
(pred-env-add/not/ref ntypes n flinteger-pred plxc))]))])

(define-specialize 2 zero?
[(n) (let ([r (get-type n)])
(cond
Expand Down Expand Up @@ -1440,25 +1331,30 @@ Notes:
(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*)])
(if (and (eq? (primref-name pr) 'integer?)
(predicate-implies? (car r*) flonum-pred))
(do-fold-predicate preinfo (lookup-primref 3 'flinteger?) e* ret r* ctxt ntypes oldtypes plxc)
(do-fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc)))

(define (do-fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
(let ([e (car e*)]
[r (predicate-intersect (car r*)
(primref->argument-predicate pr 0 1 #t))])
(cond
[(predicate-implies? val-type (primref->predicate pr #f))
(values (make-seq ctxt val true-rec)
[(predicate-implies? r (primref->predicate pr #f))
(values (make-seq ctxt `(call ,preinfo ,pr ,e) true-rec)
true-rec ntypes #f #f)]
[(predicate-disjoint? val-type (primref->predicate pr #t))
(values (make-seq ctxt val false-rec)
[(predicate-disjoint? r (primref->predicate pr #t))
(values (make-seq ctxt `(call ,preinfo ,pr ,e) false-rec)
false-rec ntypes #f #f)]
[else
(values `(call ,preinfo ,pr ,val)
(values `(call ,preinfo ,pr ,e)
ret
ntypes
(and (eq? ctxt 'test)
(pred-env-add/ref ntypes val (primref->predicate pr #t) plxc))
(pred-env-add/ref ntypes e (primref->predicate pr #t) plxc))
(and (eq? ctxt 'test)
(pred-env-add/not/ref ntypes val (primref->predicate pr #f) plxc)))])))
(pred-env-add/not/ref ntypes e (primref->predicate pr #f) plxc)))])))

(define (fold-call/primref preinfo pr e* ctxt oldtypes plxc)
(fold-primref/unrestricted preinfo pr e* ctxt oldtypes plxc))
Expand Down
Loading

0 comments on commit 41e7ab8

Please sign in to comment.