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

Merge branch 'reccas' of github.com:mflatt/ChezScheme

Browse Source 
original commit: cd641e47fd849385544aa99354d98f5b7193d237
This commit is contained in:
Matthew Flatt 2019-04-08 11:11:52 +02:00
commit 085b78aba9
3 changed files with 45 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
s/cpnanopass.ss
View File

@ -8327,6 +8327,33 @@
`(if ,(build-vector-set!-check e-v e-i e-new)
,(go e-v e-i e-new)
,(build-libcall #t src sexpr vector-set-fixnum! e-v e-i e-new)))])))
(let ()
(define (go e-v e-i)
(nanopass-case (L7 Expr) e-i
[(quote ,d)
(guard (target-fixnum? d))
(%mref ,e-v ,(+ (fix d) (constant record-data-disp)))]
[else (%mref ,e-v ,e-i ,(constant record-data-disp))]))
(define-inline 3 $record-ref
[(e-v e-i) (go e-v e-i)]))
(let ()
(define (go e-v e-i e-new)
(nanopass-case (L7 Expr) e-i
[(quote ,d)
(guard (target-fixnum? d))
(build-dirty-store e-v (+ (fix d) (constant record-data-disp)) e-new)]
[else (build-dirty-store e-v e-i (constant record-data-disp) e-new)]))
(define-inline 3 $record-set!
[(e-v e-i e-new) (go e-v e-i e-new)]))
(let ()
(define (go e-v e-i e-old e-new)
(nanopass-case (L7 Expr) e-i
[(quote ,d)
(guard (target-fixnum? d))
(build-dirty-store e-v %zero (+ (fix d) (constant record-data-disp)) e-new (make-build-cas e-old) build-cas-seq)]
[else (build-dirty-store e-v e-i (constant record-data-disp) e-new (make-build-cas e-old) build-cas-seq)]))
(define-inline 3 $record-cas!
[(e-v e-i e-old e-new) (go e-v e-i e-old e-new)]))
(let ()
(define build-bytevector-ref-check
(lambda (e-bits e-bv e-i check-mutable?)

3
s/primdata.ss
View File

@ -2193,9 +2193,12 @@
($recompile-importer-path [flags])
($record [flags cp02 unrestricted alloc]) ; first arg should be an rtd, but we don't check
($record? [flags pure mifoldable discard])
($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags])
($record-equal-procedure [flags discard])
($record-hash-procedure [flags discard])
($record-oops #;[sig [(who sub-ptr rtd) -> (bottom)]] [flags abort-op])
($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags mifoldable discard])
($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true])
($record-type-descriptor [flags pure mifoldable discard true])
($record-type-field-offsets [flags pure mifoldable discard true])
($reloc [flags])

15
s/prims.ss
View File

@ -1177,6 +1177,21 @@
(lambda (s)
(#3%immutable-fxvector? s)))
; not safe
(define $record-ref
(lambda (v i)
(#3%$record-ref v i)))
; not safe
(define $record-set!
(lambda (v i x)
(#3%$record-set! v i x)))
; not safe
(define $record-cas!
(lambda (v i old-x new-x)
(#3%$record-cas! v i old-x new-x)))
(define cons (lambda (x y) (cons x y)))
(define car