suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cptypes: rewrite implementation of primref->argument-predicate

Browse Source 
Also, remove signatures from primref. Now the record is reverted to the one in
the main ChezScheme version.

And lift most of the code outside the cptypes function.

original commit: 8f4384e0a5e1e9b383f65e097d6088b30d8069e5
This commit is contained in:
Gustavo Massaccesi 2020-03-04 14:19:00 -03:00
parent db47781c8c
commit 75872880f8
9 changed files with 157 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point # # no changes should be needed below this point #
############################################################################### ###############################################################################
Version=csv9.5.3.21 Version=csv9.5.3.22
Include=boot/$m Include=boot/$m
PetiteBoot=boot/$m/petite.boot PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot SchemeBoot=boot/$m/scheme.boot

2
mats/record.ms
View File

@ -6358,7 +6358,7 @@
(let ([b (box 4)]) (let ([b (box 4)])
(set-box! b (* 3 (unbox b))) (set-box! b (* 3 (unbox b)))
(list (box? b) (unbox b)))))))) (list (box? b) (unbox b))))))))
`(let ([gs (#2%gensym "record-box")]) `(let ([gs (#3%gensym "record-box")])
(let ([g5 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))] (let ([g5 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]
[g6 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))] [g6 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]
[g4 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]) [g4 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))])

4
s/base-lang.ss
View File

@ -14,7 +14,7 @@
;;; limitations under the License. ;;; limitations under the License.
(module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc (module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc
lookup-primref primref? primref-name primref-level primref-flags primref-arity primref-signatures lookup-primref primref? primref-name primref-level primref-flags primref-arity
sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags
preinfo-lambda-flags-set! preinfo-lambda-libspec preinfo-lambda-flags-set! preinfo-lambda-libspec
@ -23,7 +23,7 @@
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
target-fixnum? target-bignum?) target-fixnum? target-bignum?)
(module (lookup-primref primref? primref-name primref-flags primref-arity primref-signatures primref-level) (module (lookup-primref primref? primref-name primref-flags primref-arity primref-level)
(include "primref.ss") (include "primref.ss")
(define $lookup-primref (define $lookup-primref

2
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ... [(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))]))) [(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x09050315) (define-constant scheme-version #x09050316)
(define-syntax define-machine-types (define-syntax define-machine-types
(lambda (x) (lambda (x)

92
s/cptypes.ss
View File

@ -70,8 +70,6 @@ Notes:
(include "base-lang.ss") (include "base-lang.ss")
(include "fxmap.ss") (include "fxmap.ss")
(define-pass cptypes : Lsrc (ir) -> Lsrc ()
(definitions
(define (prelex-counter x plxc) (define (prelex-counter x plxc)
(or (prelex-operand x) (or (prelex-operand x)
(let ([c (unbox plxc)]) (let ([c (unbox plxc)])
@ -628,51 +626,25 @@ Notes:
[else [else
(primref-name/nqm->predicate type #t)])))) (primref-name/nqm->predicate type #t)]))))
(define (signature->argument-predicate signature pos extend?) (define (primref->argument-predicate pr pos arity extend?)
(let* ([arguments (car signature)] (let ([arguments-type ($sgetprop (primref-name pr) '*arguments-type* #f)])
[dots (memq '... arguments)]) (and arguments-type
(cond (cond
[(and dots (null? (cdr dots))) [(fx< pos (vector-length arguments-type))
(cond (primref-name/nqm->predicate (vector-ref arguments-type pos) extend?)]
[(< pos (- (length arguments) 2)) [(not arity)
(primref-name/nqm->predicate (list-ref arguments pos) extend?)] #f]
[else [(fx< pos (fx- arity 1))
(primref-name/nqm->predicate (list-ref arguments (- (length arguments) 2)) extend?)])] (let ([rest ($sgetprop (primref-name pr) '*rest-type* #f)])
[dots #f] ; TODO: Extend to handle this case, perhaps knowing the argument count. (primref-name/nqm->predicate rest extend?))]
[else [else
(cond (let ([last ($sgetprop (primref-name pr) '*last-type* #f)])
[(< pos (length arguments)) (cond
(let ([argument (list-ref arguments pos)]) [last
(cond (primref-name/nqm->predicate last extend?)]
[(equal? argument '(ptr . ptr)) [else
'pair] (let ([rest ($sgetprop (primref-name pr) '*rest-type* #f)])
[(and extend? (pair? argument)) (primref-name/nqm->predicate rest extend?))]))]))))
'pair]
[else
(primref-name/nqm->predicate argument extend?)]))]
[else
'bottom])])))
(define-threaded primref->argument-predicate/cache #f)
(define (primref->argument-predicate pr pos extend?)
(unless primref->argument-predicate/cache
(set! primref->argument-predicate/cache (make-hashtable equal-hash equal?)))
(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) (define (primref->unsafe-primref pr)
(lookup-primref 3 (primref-name pr))) (lookup-primref 3 (primref-name pr)))
@ -953,12 +925,12 @@ Notes:
(Expr n 'value oldtypes plxc)] (Expr n 'value oldtypes plxc)]
[(args rargs targs t-targs f-targs) [(args rargs targs t-targs f-targs)
(Expr args 'value oldtypes plxc)]) (Expr args 'value oldtypes plxc)])
(let* ([predn (primref->argument-predicate pr 1 #t)] (let* ([predn (primref->argument-predicate pr 1 3 #t)]
[tn (if (predicate-implies-not? rn predn) [tn (if (predicate-implies-not? rn predn)
'bottom 'bottom
tn)] tn)]
[tn (pred-env-add/ref tn n predn plxc)] [tn (pred-env-add/ref tn n predn plxc)]
[predargs (primref->argument-predicate pr 2 #t)] [predargs (primref->argument-predicate pr 2 3 #t)]
[targs (if (predicate-implies-not? rargs predargs) [targs (if (predicate-implies-not? rargs predargs)
'bottom 'bottom
targs)] targs)]
@ -1058,7 +1030,7 @@ Notes:
(let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t]) (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t])
(if (null? e*) (if (null? e*)
(values ret t) (values ret t)
(let ([pred (primref->argument-predicate pr n #t)]) (let ([pred (primref->argument-predicate pr n (length e*) #t)])
(loop (cdr e*) (loop (cdr e*)
(cdr r*) (cdr r*)
(fx+ n 1) (fx+ n 1)
@ -1075,7 +1047,7 @@ Notes:
(all-set? (prim-mask safeongoodargs) (primref-flags pr)) (all-set? (prim-mask safeongoodargs) (primref-flags pr))
(andmap (lambda (r n) (andmap (lambda (r n)
(predicate-implies? r (predicate-implies? r
(primref->argument-predicate pr n #f))) (primref->argument-predicate pr n (length e*) #f)))
r* (enumerate r*)))] r* (enumerate r*)))]
[pr (if to-unsafe [pr (if to-unsafe
(primref->unsafe-primref pr) (primref->unsafe-primref pr)
@ -1300,7 +1272,8 @@ Notes:
ir 'procedure plxc) ir 'procedure plxc)
#f #f))])) #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) (Expr : Expr (ir ctxt types plxc) -> Expr (ret types t-types f-types)
[(quote ,d) [(quote ,d)
(values ir (datum->predicate d ir) types #f #f)] (values ir (datum->predicate d ir) types #f #f)]
@ -1485,11 +1458,22 @@ Notes:
[(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)]
[(profile ,src) (values ir #f types #f #f)] [(profile ,src) (values ir #f types #f #f)]
[else ($oops who "unrecognized record ~s" ir)]) [else ($oops who "unrecognized record ~s" ir)])
; body of cptypes
(Expr ir ctxt types plxc)
)
; friendy name to use in other internal functions
; so it is similar to Expr/call and Expr/fix-tf-types
(define Expr cptypes)
; external version of cptypes: Lsrc -> Lsrc
(define (Scptypes ir)
(let-values ([(ir ret types t-types f-types) (let-values ([(ir ret types t-types f-types)
(Expr ir 'value pred-env-empty (box 0))]) (Expr ir 'value pred-env-empty (box 0))])
ir)) ir))
(set! $cptypes Scptypes)
(set! $cptypes cptypes)
) )

4
s/primdata.ss
View File

@ -869,8 +869,8 @@
(date-zone-offset [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date-zone-offset [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true])
(date-zone-name [sig [(date) -> (ptr)]] [flags pure mifoldable discard]) (date-zone-name [sig [(date) -> (ptr)]] [flags pure mifoldable discard])
(date->time-utc [sig [(date) -> (time-utc)]] [flags alloc]) (date->time-utc [sig [(date) -> (time-utc)]] [flags alloc])
(make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)] (make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]
[(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)]] [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]]
[flags alloc]) [flags alloc])
(make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc]) (make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc])
(set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true]) (set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true])

131
s/priminfo.ss
View File

@ -13,12 +13,12 @@
;;; See the License for the specific language governing permissions and ;;; See the License for the specific language governing permissions and
;;; limitations under the License. ;;; limitations under the License.
(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-signatures priminfo-arity primvec (module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-arity primvec get-priminfo
get-priminfo priminfo-result-type) priminfo-arguments-type priminfo-rest-type priminfo-last-type priminfo-result-type)
(define-record-type priminfo (define-record-type priminfo
(nongenerative) (nongenerative)
(sealed #t) (sealed #t)
(fields unprefixed libraries mask result-type signatures arity)) (fields unprefixed libraries mask arity arguments-type rest-type last-type result-type))
(define make-parameterlike box) (define make-parameterlike box)
@ -113,28 +113,91 @@
[else 'ptr]))] ; a strange case, like list* and cons* [else 'ptr]))] ; a strange case, like list* and cons*
[else #f])) ; multivalued [else #f])) ; multivalued
(define signature->interface (define (signature-parse signature*)
(lambda (sig) (define (ellipsis? x) (eq? x '...))
(define (ellipsis? x) (eq? x '...)) (define (type? x)
(define (type? x) (syntax-case x ()
(syntax-case x () [(t1 . t2) (and (type? #'t1) (type? #'t2))]
[(t1 . t2) (and (type? #'t1) (type? #'t2))] [t (and (symbol? #'t) (not (ellipsis? #'t)))]))
[t (and (symbol? #'t) (not (ellipsis? #'t)))])) (and (not (null? signature*))
(syntax-case (car sig) () (map (lambda (sig)
[(a ...) (syntax-case (car sig) ()
(andmap type? #'(a ...)) [(a ...)
(length #'(a ...))] (andmap type? #'(a ...))
[(a ... b dots) (list (list->vector #'(a ...)) #f #f)]
(and (andmap type? #'(a ...)) [(a ... b dots)
(type? #'b) (and (andmap type? #'(a ...))
(ellipsis? #'dots)) (type? #'b)
(- -1 (length #'(a ...)))] (ellipsis? #'dots))
[(a ... b dots d) (list (list->vector #'(a ...)) #'b #f)]
(and (andmap type? #'(a ...)) [(a ... b dots d)
(type? #'b) (and (andmap type? #'(a ...))
(ellipsis? #'dots) (type? #'b)
(type? #'d)) (ellipsis? #'dots)
(- -2 (length #'(a ...)))]))) (type? #'d))
(list (list->vector #'(a ...)) #'b #'d)]
[else
($oops 'prims "unexpected pattern ~s in signature ~s" sig signature*)]))
signature*)))
(define (parsed-signature->interface psignature*)
(and psignature*
(map (lambda (sig)
(define len (vector-length (car sig)))
(cond
[(and (not (cadr sig)) (not (caddr sig)))
len]
[(not (caddr sig))
(- -1 len)]
[else
(- -2 len)]))
psignature*)))
(define (parsed-signature->arguments-type psignature*)
; the last vector must be longer than the other, and the other must be subvectors
(and psignature*
(let ([longest (car (car (last-pair psignature*)))]) ; assume they are ordered
(cond
[(andmap (lambda (sig)
(define other (car sig))
(define l (vector-length other))
(let loop ([i 0])
(or (fx= i l)
(and (equal? (vector-ref longest i) (vector-ref other i))
(loop (fx+ i 1))))))
psignature*)
longest]
[else
; the arguments disagree
#f]))))
(define (parsed-signature->rest-type psignature*)
; only one must be not #f
(and psignature*
(let loop ([psig* (map cadr psignature*)] [found #f])
(cond
[(null? psig*)
found]
[(not found)
(loop (cdr psig*) (car psig*))]
[(not (car psig*))
(loop (cdr psig*) found)]
[else
($oops 'prims "unexpected two values of rest argument ~s and ~s in signature with ~s" found (car psig*) psignature*)]))))
(define (parsed-signature->last-type psignature*)
; only one must be not #f
(and psignature*
(let loop ([psig* (map caddr psignature*)] [found #f])
(cond
[(null? psig*)
found]
[(not found)
(loop (cdr psig*) (car psig*))]
[(not (car psig*))
(loop (cdr psig*) found)]
[else
($oops 'prims "unexpected two values of last argument ~s and ~s in signature with ~s" found (car psig*) psignature*)]))))
(define put-priminfo! (define put-priminfo!
(lambda (prim unprefixed lib* mask sig*) (lambda (prim unprefixed lib* mask sig*)
@ -157,13 +220,19 @@
($oops 'prims "inconsistent single-value information for ~s" prim)) ($oops 'prims "inconsistent single-value information for ~s" prim))
(when (and (eq? result-type 'ptr) (all-set? (prim-mask true) mask)) (when (and (eq? result-type 'ptr) (all-set? (prim-mask true) mask))
($oops 'prims "inconsistent true information for ~s ~s ~s ~s" prim result-type mask sig*)) ($oops 'prims "inconsistent true information for ~s ~s ~s ~s" prim result-type mask sig*))
(let ([mask (fxlogor mask (let* ([mask (fxlogor mask
(if (eq? result-type 'bottom) (prim-mask abort-op) 0) (if (eq? result-type 'bottom) (prim-mask abort-op) 0)
(if (eq? result-arity 'single) (prim-mask single-valued) 0) (if (eq? result-arity 'single) (prim-mask single-valued) 0)
(if (signature-boolean? sig*) (prim-mask boolean-valued) 0) (if (signature-boolean? sig*) (prim-mask boolean-valued) 0)
(if (signature-true? sig*) (prim-mask true) 0))]) (if (signature-true? sig*) (prim-mask true) 0))]
[psig* (signature-parse sig*)]
[arguments-type (parsed-signature->arguments-type psig*)])
(eq-hashtable-set! prim-db prim (eq-hashtable-set! prim-db prim
(make-priminfo unprefixed lib* mask result-type sig* (map signature->interface sig*))))))) (make-priminfo unprefixed lib* mask (parsed-signature->interface psig*)
arguments-type
(and arguments-type (parsed-signature->rest-type psig*)) ; if arguments-type is confused, clean rest-type and last-type
(and arguments-type (parsed-signature->last-type psig*))
result-type))))))
(define-syntax define-symbol-flags* (define-syntax define-symbol-flags*
(lambda (x) (lambda (x)

4
s/primref.ss
View File

@ -14,9 +14,9 @@
;;; limitations under the License. ;;; limitations under the License.
(define-record-type primref (define-record-type primref
(nongenerative #{primref a0xltlrcpeygsahopkplcn-3}) (nongenerative #{primref a0xltlrcpeygsahopkplcn-2})
(sealed #t) (sealed #t)
(fields name flags arity signatures)) (fields name flags arity))
(define primref-level (define primref-level
(lambda (pr) (lambda (pr)

16
s/primvars.ss
View File

@ -18,14 +18,16 @@
(include "primref.ss") (include "primref.ss")
(define record-prim! (define record-prim!
(lambda (prim unprefixed flags arity result-type signatures) (lambda (prim unprefixed flags arity arguments-type rest-type last-type result-type)
(unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed)) (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed))
($sputprop prim '*flags* flags) ($sputprop prim '*flags* flags)
(when arguments-type ($sputprop prim '*arguments-type* arguments-type))
(when rest-type ($sputprop prim '*rest-type* rest-type))
(when last-type ($sputprop prim '*last-type* last-type))
(when result-type ($sputprop prim '*result-type* result-type)) (when result-type ($sputprop prim '*result-type* result-type))
(when (any-set? (prim-mask (or primitive system)) flags) (when (any-set? (prim-mask (or primitive system)) flags)
(let ([arity (and (not (null? arity)) arity)]) ($sputprop prim '*prim2* (make-primref prim flags arity))
($sputprop prim '*prim2* (make-primref prim flags arity signatures)) ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity)))))
($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity signatures))))))
(define-syntax setup (define-syntax setup
(lambda (x) (lambda (x)
@ -38,8 +40,10 @@
'#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info)) '#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info))
'#,(datum->syntax #'* (vector-map priminfo-mask v-info)) '#,(datum->syntax #'* (vector-map priminfo-mask v-info))
'#,(datum->syntax #'* (vector-map priminfo-arity v-info)) '#,(datum->syntax #'* (vector-map priminfo-arity v-info))
'#,(datum->syntax #'* (vector-map priminfo-result-type v-info)) '#,(datum->syntax #'* (vector-map priminfo-arguments-type v-info))
'#,(datum->syntax #'* (vector-map priminfo-signatures v-info))))))) '#,(datum->syntax #'* (vector-map priminfo-rest-type v-info))
'#,(datum->syntax #'* (vector-map priminfo-last-type v-info))
'#,(datum->syntax #'* (vector-map priminfo-result-type v-info)))))))
(for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist)) (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist))
setup) setup)