Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

fix record? primitive at optimize-level 3 #734

Merged
merged 2 commits into from
Oct 20, 2023
Merged

fix record? primitive at optimize-level 3 #734

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
2259e2e
fix indentation in mat
owaddell-beckman Oct 19, 2023
a2eda72
fix #3%record? inline primitive
owaddell-beckman Oct 19, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
43 changes: 23 additions & 20 deletions mats/record.ms
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4079,26 +4079,29 @@
(let ([record? #%$sealed-record?])
(list (record? 3 Dtd) (record? a Dtd) (record? b Dtd) (record? c Dtd) (record? d Dtd) (record? e Dtd)))
'(#f #f #f #f #t #f))))
(begin
(define (get-supertype-uid) '#{supertype a3utgl1aoz8jzrg100-0})
(define (get-subtype-uid) '#{subtype a3utgl1aoz8jzrg100-1})
(define $keep-rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define $keep-rtd2 (make-record-type-descriptor 'subtype $keep-rtd (get-subtype-uid) #f #f (cons 1 1)))
(let ()
(define rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1)))
(define val ((record-constructor rtd2) 0 1))
(record? val rtd)))
(eval `(let ()
(define rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1)))
(define val ',(read (open-string-input-port "#[#{supertype a3utgl1aoz8jzrg100-0} 0]")))
(record? val rtd)))
(eval `(let ()
(define rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1)))
(define val ',(read (open-string-input-port "#[#{subtype a3utgl1aoz8jzrg100-1} 0 1]")))
(record? val rtd)))
(begin
(define (get-supertype-uid) '#{supertype a3utgl1aoz8jzrg100-0})
(define (get-subtype-uid) '#{subtype a3utgl1aoz8jzrg100-1})
(define $keep-rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define $keep-rtd2 (make-record-type-descriptor 'subtype $keep-rtd (get-subtype-uid) #f #f (cons 1 1)))
(let ()
(define rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1)))
(define val ((record-constructor rtd2) 0 1))
(record? val rtd)))
(eval `(let ()
(define rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1)))
(define val ',(read (open-string-input-port "#[#{supertype a3utgl1aoz8jzrg100-0} 0]")))
(record? val rtd)))
(eval `(let ()
(define rtd (make-record-type-descriptor 'supertype #f (get-supertype-uid) #f #f (cons 1 1)))
(define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1)))
(define val ',(read (open-string-input-port "#[#{subtype a3utgl1aoz8jzrg100-1} 0 1]")))
(record? val rtd)))
(let ([ip (open-input-string "#f")])
;; check that expand-primitives respects applicative order for record?
(eq? 'bailed (call/cc (lambda (k) (#3%record? (read ip) (k 'bailed))))))
)

(mat record-type-mismatch
Expand Down
5 changes: 5 additions & 0 deletions release_notes/release_notes.stex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2700,6 +2700,11 @@ in fasl files does not generally make sense.
%-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes}

\subsection{Incorrect code for \scheme{record?} at optimize-level 3 (9.9.9)}

At optimize-level 3, the \scheme{record?} predicate could short circuit without
evaluating the \var{rtd} expression.

\subsection{Incorrect result from \scheme{Sinteger64} on 32-bit platforms (9.6.4)}

On 32-bit platforms, calling \scheme{Sinteger64} or \scheme{Sunsigned64}
Expand Down
8 changes: 4 additions & 4 deletions s/cpprim.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7831,7 +7831,7 @@
(vector-length (rtd-ancestry d)))]
[else #f])])
;; `t` is rtd of `e`, and it's used once
(define (compare-at-depth t known-depth)
(define (compare-at-depth e-rtd t known-depth)
(cond
[(eqv? known-depth (constant minimum-ancestry-vector-length))
;; no need to check ancestry array length
Expand Down Expand Up @@ -7865,16 +7865,16 @@
,(%constant sfalse)))))))]))
(cond
[assume-record?
(compare-at-depth (%mref ,e ,(constant typed-object-type-disp)) known-depth)]
(compare-at-depth e-rtd (%mref ,e ,(constant typed-object-type-disp)) known-depth)]
[else
(let ([t (make-tmp 't)])
(bind #t (e)
(bind #t (e e-rtd) ;; also bind e-rtd to maintain applicative order in case `and` short-circuits
(build-and
(%type-check mask-typed-object type-typed-object ,e)
`(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))])
,(build-and
(%type-check mask-record type-record ,t)
(compare-at-depth t known-depth))))))]))))
(compare-at-depth e-rtd t known-depth))))))]))))
(define-inline 3 record?
[(e) (build-record? e)]
[(e e-rtd)
Expand Down