define-record-type methods and interfaces

LOG

@@ -2301,3 +2301,67 @@
     record.ms, root-experr-compile-0-f-f-f
 - updated comments describing the new features
     record-defn.ss
+- fixed newly improved generate-temporaries so it doesn't loop
+  indefinitely on cycles in the elemenents of the input list.
+    syntax.ss,
+    8.mo, root-experr-compile-0-f-f-f
+- cp0 record-construct handlers now keep record-type wrappers when
+  propagating constants and refs.
+    cp0.ss
+- added immutable-vector primitiive along with cp0 handling of
+  fully (foldable) and partially static immutable vectors.
+    primdata.ss, cpnanopass.ss, base-lang.ss, cpcheck.ss, cpletrec.ss,
+    cpcommonize.ss, cprep.ss, prims.ss, cp0.ss,
+    5_6.ms, cp0.ms
+- define-values now uses an immutable vector rather than a mutable
+  vector to package the values.
+    syntax.ss
+- now working harder to determine the truth of the test part of an
+  if expression in order to eliminate the if itself.
+    cp0.ss,
+    cp0.ms
+- eliminated some code duplication in rfa and rfm helpers.
+    cp0.ss
+- now using compile-time (nongenerative) record types as proxies
+  for the run-time (generative) counterparts for defining record-type
+  accessors and mutators.  this improves cross-library optimization
+  of generative record types in general, and specifically breaks
+  an otherwise unresolvable cycle among the internal definitions
+  of a record type with methods for which cpvalid was inserting
+  valid checks and assignments.
+    record-defn.ss, record.ss, cp0.ss, primdata.ss,
+    record.ms
+- improved handling of records with methods.  Lsrc record-type form
+  now hosts base-rtd and extras, which cp0 now uses to inline methods
+  through vtable indirects when it can.  cp0 also propagates
+  record-type information through record forms, i.e., it no longer
+  drops the record-type wrapper around the record-type expression
+  that gets placed in the record form.  cp0's record? handler also
+  now recognizes record-types as records.
+    cp0.ss, base-lang.ss, cpletrec.ss, cpcommonize.ss, cprep.ss,
+    interpret.ss,
+    record.ms
+- fixed cp0 handler for $record to handle the case where the rtrd is
+  constant and all fields are immutable.  it was punting this case and
+  thus possibly disabling some optimization.
+    cp0.ss
+- added cp0 handler for $record-type-field-offsets.
+    cp0.ss
+- define-record-type now requires that all the ancestors of a new
+  type with methods must be known at cmompile time, i.e., must all
+  have been specified via parent rather than parent-rtd.  this
+  ensures we can determine the full set of methods that the type
+  inherits at expand time, hence the set of new generics that the
+  new type definition should bind.
+    record-defn.ss,
+    record.ms, root-experr-compile-0-f-f-f
+- interface methods now use an out-of-line $query-interface operator,
+  interfaces are now packaged in an immutable vector, and cp0 tries
+  to fold $query-interface at compile time when possible.
+    cp0.ss, record-defn.ss, primdata.ss,
+    record.ms
+- added open-interface as a friendly wrapper on $query-interface.
+    record-defn.ss, primdata.ss,
+    record.ms, root-experr-compile-0-f-f-f
+- updated patch files
+    patch-compile-0-f-t-f, patch-compile-0-t-f-f, patch-interpret-0-f-t-f

mats/5_6.ms

@@ -18,6 +18,23 @@
     (eq? (vector) '#())
  )
 
+(mat immutable-vector
+    (equal? (immutable-vector 1 2 3 4) (vector->immutable-vector '#(1 2 3 4)))
+    (eq? (immutable-vector) (vector->immutable-vector '#()))
+    (begin
+      (define (f x)
+        (let ([v (immutable-vector (begin (write 'a) (+ x 1)) (begin (write 'a) 2) (begin (write 'a) (cons 3 x)))])
+          (for-each write
+            (list
+              (begin (write 'b) (vector-ref v 0))
+              (begin (write 'b) (vector-ref v 1))
+              (begin (write 'b) (vector-ref v 2))))))
+      #t)
+    (equal?
+      (with-output-to-string (lambda () (f 7)))
+      "aaabbb82(3 . 7)")
+ )
+
 (mat make-vector
     (eqv? (vector-length (make-vector 10)) 10)
     (eqv? (vector-length (make-vector 100)) 100)

mats/8.ms

@@ -794,6 +794,10 @@
     (load "testfile.so")
     #t)
   (equal? $gt-x '(53 -10 . 17))
+ ; make sure generate-temporaries doesn't loop indefinitely on cycles
+  (error? ; cycle
+    (generate-temporaries (let ([x (list 'a 'b)]) (set-cdr! (cdr x) x) x)))
+  (= (length (generate-temporaries (let ([x (list 'a 'b 'c)]) (set-car! (cddr x) x) x))) 3)
 )
 
 (mat syntax->list

mats/cp0.ms

@@ -2673,6 +2673,26 @@
                  (begin (#2%write 'f) ($yyy))
                  (begin (#2%write 'g) ($zzz))))
              (begin (#2%write 'h) 3)))))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+      (expand/optimize
+        '(immutable-vector 1 2 3)))
+    ''#(1 2 3))
+  (equivalent-expansion?
+    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
+      (expand/optimize
+        '(lambda (x)
+           (let ([v (begin (write 'a) (immutable-vector x 2 3))])
+             (list
+               (begin (write 'b) (vector-ref v 0))
+               (begin (write 'c) (vector-ref v 1))
+               (begin (write 'd) (vector-ref v 2)))))))
+    '(lambda (x)
+       (#2%write 'a)
+       (#2%list
+         (begin (#2%write 'b) x)
+         (begin (#2%write 'c) 2)
+         (begin (#2%write 'd) 3))))
  )
 
 (mat let-pushing
@@ -2887,3 +2907,53 @@
         `(lambda (x) (= x x))) ; x could be +nan.0
       `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x))))
 )
+
+(mat if
+  (equal?
+    (let ([f (lambda (x) (+ x 1))] [g (lambda (x) (+ x 2))])
+      (define (q1) (and f (f 3)))
+      (define (q2) (and g (g 7)))
+      (set! g values)
+      (list (q1) (q2)))
+    '(4 7))
+  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+    (equivalent-expansion?
+      (expand/optimize
+        '(let ([f (lambda (x) (+ x 1))] [g (lambda (x) (+ x 2))])
+           (define (q1) (and f (f 3)))
+           (define (q2) (and g (g 7)))
+           (set! g values)
+           (list (q1) (q2))))
+      '(let ([g (lambda (x) (#2%+ 2 x))])
+         (set! g #2%values)
+         (#2%list 4 (if g (g 7) #f)))))
+  (equal?
+    (let ([x (list 3)]) (and x (car x)))
+    3)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ([x (list 3)]) (and x (car x)))))
+    3)
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x) (let ([p (list x)]) (and p (car p))))))
+    '(lambda (x) x))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(lambda (x) (let ([p (list x)]) (and p (list p))))))
+    '(lambda (x) (#2%list (#2%list x))))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize
+        '(let ()
+           (define-record-type a (fields x))
+           (let ([q (make-a 17)])
+             (if q q (list q))))))
+    '(#3%$record 
+       (#2%$make-record-type-descriptor #!base-rtd 'a #f #f #f #f
+         '#((immutable x)) 'define-record-type)
+       17))
+)

mats/patch-compile-0-f-t-f

@@ -1,5 +1,5 @@
-*** patches-work-dir/errors-compile-0-f-f-f	2021-12-03 16:51:41.000000000 -0800
---- patches-work-dir/errors-compile-0-f-t-f	2021-12-03 16:51:41.000000000 -0800
+*** patches-work-dir/errors-compile-0-f-f-f	2022-02-03 16:55:57.000000000 -0800
+--- patches-work-dir/errors-compile-0-f-t-f	2022-02-03 16:55:57.000000000 -0800
 ***************
 *** 54,60 ****
   primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@@ -397,8 +397,8 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "unrecognized parent record type fratrat".
 ***************
-*** 7921,7939 ****
-  record.mo:Expected error in mat oop: "record-type definition has multiple method clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))".
+*** 7921,7932 ****
+  record.mo:Expected error in mat oop: "record-type definition has multiple methods clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))".
   record.mo:Expected error in mat oop: "invalid assignment of immutable field (set! x v)".
   record.mo:Expected error in mat oop: "variable blast-x-set! is not bound".
 ! record.mo:Expected error in mat oop: "#<record of type <q>> is not of type #<record type <r>>".
@@ -409,16 +409,9 @@
 ! record.mo:Expected error in mat oop: "#<record of type <r>> is not of type #<record type <s>>".
   record.mo:Expected error in mat oop: "record-rtd: #<e> is not a record".
   record.mo:Expected error in mat oop: "parent record type is sealed b".
-  record.mo:Expected error in mat oop: "m1: not applicable to #<record of type b>".
-  record.mo:Expected error in mat oop: "m1: not applicable to #<record of type b>".
-  record.mo:Expected error in mat oop: "m1: not applicable to #<record of type b>".
-  record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined".
-! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #<procedure>".
-  record.mo:Expected error in mat oop-contributed: "no inherited foo method for <a> in (super)".
-  record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent <root>) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent <root>) (fields) (protocol (...)) (methods)) 0)".
-  record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent <root>) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))".
---- 7921,7939 ----
-  record.mo:Expected error in mat oop: "record-type definition has multiple method clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))".
+  record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))".
+--- 7921,7932 ----
+  record.mo:Expected error in mat oop: "record-type definition has multiple methods clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))".
   record.mo:Expected error in mat oop: "invalid assignment of immutable field (set! x v)".
   record.mo:Expected error in mat oop: "variable blast-x-set! is not bound".
 ! record.mo:Expected error in mat oop: "<r>-mupu1: #<record of type <q>> is not of type #<record type <r>>".
@@ -429,10 +422,20 @@
 ! record.mo:Expected error in mat oop: "s$mupu2-set!: #<record of type <r>> is not of type #<record type <s>>".
   record.mo:Expected error in mat oop: "record-rtd: #<e> is not a record".
   record.mo:Expected error in mat oop: "parent record type is sealed b".
-  record.mo:Expected error in mat oop: "m1: not applicable to #<record of type b>".
-  record.mo:Expected error in mat oop: "m1: not applicable to #<record of type b>".
-  record.mo:Expected error in mat oop: "m1: not applicable to #<record of type b>".
+  record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))".
+***************
+*** 7936,7942 ****
+  record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined".
+  record.mo:Expected error in mat oop: "unrecognized interface method name m2".
+  record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface <A> ((foo m1) (foo m2)) a)".
+! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #<procedure>".
+  record.mo:Expected error in mat oop-contributed: "no inherited foo method for <a> in (super)".
+  record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent <root>) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent <root>) (fields) (protocol (...)) (methods)) 0)".
+  record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent <root>) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))".
+--- 7936,7942 ----
   record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined".
+  record.mo:Expected error in mat oop: "unrecognized interface method name m2".
+  record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface <A> ((foo m1) (foo m2)) a)".
 ! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #<procedure make-<a>>".
   record.mo:Expected error in mat oop-contributed: "no inherited foo method for <a> in (super)".
   record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent <root>) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent <root>) (fields) (protocol (...)) (methods)) 0)".