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 #
###############################################################################
Version=csv9.5.3.21
Version=csv9.5.3.22
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

2
mats/record.ms
View File

@ -6358,7 +6358,7 @@
(let ([b (box 4)])
(set-box! b (* 3 (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)))]
[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)))])

4
s/base-lang.ss
View File

@ -14,7 +14,7 @@
;;; limitations under the License.
(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
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags
preinfo-lambda-flags-set! preinfo-lambda-libspec
@ -23,7 +23,7 @@
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
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")
(define $lookup-primref

2
s/cmacros.ss
View File

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

92
s/cptypes.ss
View File

@ -70,8 +70,6 @@ Notes:
(include "base-lang.ss")
(include "fxmap.ss")
(define-pass cptypes : Lsrc (ir) -> Lsrc ()
(definitions
(define (prelex-counter x plxc)
(or (prelex-operand x)
(let ([c (unbox plxc)])
@ -628,51 +626,25 @@ Notes:
[else
(primref-name/nqm->predicate type #t)]))))
(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-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->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)))
@ -953,12 +925,12 @@ Notes:
(Expr n 'value oldtypes plxc)]
[(args rargs targs t-targs f-targs)
(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)
'bottom
tn)]
[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)
'bottom
targs)]
@ -1058,7 +1030,7 @@ Notes:
(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)])
(let ([pred (primref->argument-predicate pr n (length e*) #t)])
(loop (cdr e*)
(cdr r*)
(fx+ n 1)
@ -1075,7 +1047,7 @@ Notes:
(all-set? (prim-mask safeongoodargs) (primref-flags pr))
(andmap (lambda (r n)
(predicate-implies? r
(primref->argument-predicate pr n #f)))
(primref->argument-predicate pr n (length e*) #f)))
r* (enumerate r*)))]
[pr (if to-unsafe
(primref->unsafe-primref pr)
@ -1300,7 +1272,8 @@ Notes:
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)]
@ -1485,11 +1458,22 @@ Notes:
[(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)
)
; 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)
(Expr ir 'value pred-env-empty (box 0))])
ir))
(set! $cptypes cptypes)
(set! $cptypes Scptypes)
)

4
s/primdata.ss
View File

@ -869,8 +869,8 @@
(date-zone-offset [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true])
(date-zone-name [sig [(date) -> (ptr)]] [flags pure mifoldable discard])
(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)]
[(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (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 sub-fixnum) -> (date)]]
[flags alloc])
(make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc])
(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
;;; limitations under the License.
(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-signatures priminfo-arity primvec
get-priminfo priminfo-result-type)
(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-arity primvec get-priminfo
priminfo-arguments-type priminfo-rest-type priminfo-last-type priminfo-result-type)
(define-record-type priminfo
(nongenerative)
(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)
@ -113,28 +113,91 @@
[else 'ptr]))] ; a strange case, like list* and cons*
[else #f])) ; multivalued
(define signature->interface
(lambda (sig)
(define (ellipsis? x) (eq? x '...))
(define (type? x)
(syntax-case x ()
[(t1 . t2) (and (type? #'t1) (type? #'t2))]
[t (and (symbol? #'t) (not (ellipsis? #'t)))]))
(syntax-case (car sig) ()
[(a ...)
(andmap type? #'(a ...))
(length #'(a ...))]
[(a ... b dots)
(and (andmap type? #'(a ...))
(type? #'b)
(ellipsis? #'dots))
(- -1 (length #'(a ...)))]
[(a ... b dots d)
(and (andmap type? #'(a ...))
(type? #'b)
(ellipsis? #'dots)
(type? #'d))
(- -2 (length #'(a ...)))])))
(define (signature-parse signature*)
(define (ellipsis? x) (eq? x '...))
(define (type? x)
(syntax-case x ()
[(t1 . t2) (and (type? #'t1) (type? #'t2))]
[t (and (symbol? #'t) (not (ellipsis? #'t)))]))
(and (not (null? signature*))
(map (lambda (sig)
(syntax-case (car sig) ()
[(a ...)
(andmap type? #'(a ...))
(list (list->vector #'(a ...)) #f #f)]
[(a ... b dots)
(and (andmap type? #'(a ...))
(type? #'b)
(ellipsis? #'dots))
(list (list->vector #'(a ...)) #'b #f)]
[(a ... b dots d)
(and (andmap type? #'(a ...))
(type? #'b)
(ellipsis? #'dots)
(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!
(lambda (prim unprefixed lib* mask sig*)
@ -157,13 +220,19 @@
($oops 'prims "inconsistent single-value information for ~s" prim))
(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*))
(let ([mask (fxlogor mask
(if (eq? result-type 'bottom) (prim-mask abort-op) 0)
(if (eq? result-arity 'single) (prim-mask single-valued) 0)
(if (signature-boolean? sig*) (prim-mask boolean-valued) 0)
(if (signature-true? sig*) (prim-mask true) 0))])
(let* ([mask (fxlogor mask
(if (eq? result-type 'bottom) (prim-mask abort-op) 0)
(if (eq? result-arity 'single) (prim-mask single-valued) 0)
(if (signature-boolean? sig*) (prim-mask boolean-valued) 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
(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*
(lambda (x)

4
s/primref.ss
View File

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

16
s/primvars.ss
View File

@ -18,14 +18,16 @@
(include "primref.ss")
(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))
($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 (any-set? (prim-mask (or primitive system)) flags)
(let ([arity (and (not (null? arity)) arity)])
($sputprop prim '*prim2* (make-primref prim flags arity signatures))
($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity signatures))))))
($sputprop prim '*prim2* (make-primref prim flags arity))
($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity)))))
(define-syntax setup
(lambda (x)
@ -38,8 +40,10 @@
'#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info))
'#,(datum->syntax #'* (vector-map priminfo-mask v-info))
'#,(datum->syntax #'* (vector-map priminfo-arity v-info))
'#,(datum->syntax #'* (vector-map priminfo-result-type v-info))
'#,(datum->syntax #'* (vector-map priminfo-signatures v-info)))))))
'#,(datum->syntax #'* (vector-map priminfo-arguments-type 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))
setup)