fix #3%record? inline primitive

cisco · Oct 19, 2023 · a2eda72 · a2eda72
1 parent 2259e2e
commit a2eda72
Show file tree

Hide file tree

Showing 3 changed files with 12 additions and 4 deletions.
diff --git 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
@@ -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
@@ -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)