From 2259e2e0586b3b3e19de55beb99aa19a8887acf0 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Thu, 19 Oct 2023 18:11:33 -0400 Subject: [PATCH 1/2] fix indentation in mat --- mats/record.ms | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/mats/record.ms b/mats/record.ms index 77ee6f93b..6fedd80bd 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -4079,26 +4079,26 @@ (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))) ) (mat record-type-mismatch From a2eda72aa8391bc0941b21b9181e42f317d673fa Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Thu, 19 Oct 2023 18:11:46 -0400 Subject: [PATCH 2/2] fix #3%record? inline primitive --- mats/record.ms | 3 +++ release_notes/release_notes.stex | 5 +++++ s/cpprim.ss | 8 ++++---- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/mats/record.ms b/mats/record.ms index 6fedd80bd..bb7708698 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -4099,6 +4099,9 @@ (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 diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 49f7fd4c3..be26fd325 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -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} diff --git a/s/cpprim.ss b/s/cpprim.ss index c00dace8b..7af9cdc82 100644 --- a/s/cpprim.ss +++ b/s/cpprim.ss @@ -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 @@ -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)