Add specialized RuntimeRepr instances for Complex and LispArray types. (

#1362)
coalton-lang · Jan 17, 2025 · 889a533 · 889a533
1 parent 72eacde
commit 889a533
Show file tree

Hide file tree

Showing 5 changed files with 100 additions and 48 deletions.
diff --git a/library/lisparray.lisp b/library/lisparray.lisp
@@ -31,6 +31,12 @@ These arrays are represented as possibly specialized `(cl:simple-array <type> (c
 
 Whether or not the arrays are specialized depends on the underlying Lisp implementation. Consult `cl:upgraded-array-element-type` to determine whether `LispArray` may get specialized.")
 
+  (define-instance (types:RuntimeRepr :t => types:RuntimeRepr (LispArray :t))
+    (define (types:runtime-repr v)
+      (let ((element-type (types:runtime-repr (types:proxy-inner v))))
+        (lisp types:LispType (element-type)
+          `(cl:simple-array ,element-type (cl:*))))))
+
   (declare make (types:RuntimeRepr :t => UFix -> :t -> LispArray :t))
   (define (make n x)
     "Make a new `LispArray` of length `n` initialized to `x`.

diff --git a/library/math/complex.lisp b/library/math/complex.lisp
@@ -8,7 +8,8 @@
           #:coalton-library/utils
           #:coalton-library/math/arith)
   (:local-nicknames
-   (#:arith #:coalton-library/math/arith))
+   (#:arith #:coalton-library/math/arith)
+   (#:types #:coalton-library/types))
   (:export
    #:complex
    #:real-part
@@ -24,13 +25,25 @@
 #+coalton-release
 (cl:declaim #.coalton-impl/settings:*coalton-optimize-library*)
 
+(cl:defvar *native-complex-types* cl:nil
+  "A list of Common Lisp types that are native arguments to `cl:complex`.
+This list is populated by the macro `%define-native-complex-instances`
+below.")
+
 (coalton-toplevel
   ;; The representation of (Complex :t) is specially dealt with by the
   ;; compiler in lisp-type.lisp.
   (define-type (Complex :a)
     "Complex number that may either have a native or constructed representation."
     (%Complex :a :a))
-)
+
+  (define-instance (types:RuntimeRepr :t => types:RuntimeRepr (Complex :t))
+    (define (types:runtime-repr a)
+      (let ((inner-type (types:runtime-repr (types:proxy-inner a))))
+        (lisp types:LispType (inner-type)
+          (cl:if (cl:member inner-type *native-complex-types*)
+                 `(cl:complex ,inner-type)
+                 'Complex))))))
 
 ;; Quirk: We had to split the above COALTON-TOPLEVEL from the bottom
 ;; one because Allegro needs to know about Complex before it gets used
@@ -128,60 +141,64 @@
              (general/ (imag-part dividend) divisor))))
 
 (cl:defmacro %define-native-complex-instances (type repr)
+
   (cl:let
       ((equal (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-COMPLEX-EQUAL")))
        (plus (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-COMPLEX-PLUS")))
        (minus (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-COMPLEX-MINUS")))
        (times (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-COMPLEX-TIMES")))
        (divide (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-COMPLEX-DIVIDE"))))
 
-    `(coalton-toplevel
-       (define-instance (Complex ,type)
-         (define (complex a b)
+    `(cl:progn
+       (cl:pushnew ',repr *native-complex-types* :test 'cl:equal)
+
+       (coalton-toplevel
+         (define-instance (Complex ,type)
+           (define (complex a b)
+             (lisp (Complex ,type) (a b)
+               (cl:declare (cl:type ,repr a b))
+               (cl:complex a b)))
+           (define (real-part a)
+             (lisp ,type (a)
+               (cl:realpart a)))
+           (define (imag-part a)
+             (lisp ,type (a)
+               (cl:imagpart a))))
+
+         (specialize complex-equal ,equal (Complex ,type -> Complex ,type -> Boolean))
+         (declare ,equal (Complex ,type -> Complex ,type -> Boolean))
+         (define (,equal a b)
+           (lisp Boolean (a b)
+             (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
+             (cl:= a b)))
+
+         (specialize complex-plus ,plus (Complex ,type -> Complex ,type -> Complex ,type))
+         (declare ,plus (Complex ,type -> Complex ,type -> Complex ,type))
+         (define (,plus a b)
+           (lisp (Complex ,type) (a b)
+             (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
+             (cl:+ a b)))
+
+         (specialize complex-minus ,minus (Complex ,type -> Complex ,type -> Complex ,type))
+         (declare ,minus (Complex ,type -> Complex ,type -> Complex ,type))
+         (define (,minus a b)
+           (lisp (Complex ,type) (a b)
+             (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
+             (cl:- a b)))
+
+         (specialize complex-times ,times (Complex ,type -> Complex ,type -> Complex ,type))
+         (declare ,times (Complex ,type -> Complex ,type -> Complex ,type))
+         (define (,times a b)
+           (lisp (Complex ,type) (a b)
+             (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
+             (cl:* a b)))
+
+         (specialize complex-divide ,divide (Complex ,type -> Complex ,type -> Complex ,type))
+         (declare ,divide (Complex ,type -> Complex ,type -> Complex ,type))
+         (define (,divide a b)
            (lisp (Complex ,type) (a b)
-             (cl:declare (cl:type ,repr a b))
-             (cl:complex a b)))
-         (define (real-part a)
-           (lisp ,type (a)
-             (cl:realpart a)))
-         (define (imag-part a)
-           (lisp ,type (a)
-             (cl:imagpart a))))
-
-       (specialize complex-equal ,equal (Complex ,type -> Complex ,type -> Boolean))
-       (declare ,equal (Complex ,type -> Complex ,type -> Boolean))
-       (define (,equal a b)
-         (lisp Boolean (a b)
-           (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
-           (cl:= a b)))
-
-       (specialize complex-plus ,plus (Complex ,type -> Complex ,type -> Complex ,type))
-       (declare ,plus (Complex ,type -> Complex ,type -> Complex ,type))
-       (define (,plus a b)
-         (lisp (Complex ,type) (a b)
-           (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
-           (cl:+ a b)))
-
-       (specialize complex-minus ,minus (Complex ,type -> Complex ,type -> Complex ,type))
-       (declare ,minus (Complex ,type -> Complex ,type -> Complex ,type))
-       (define (,minus a b)
-         (lisp (Complex ,type) (a b)
-           (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
-           (cl:- a b)))
-
-       (specialize complex-times ,times (Complex ,type -> Complex ,type -> Complex ,type))
-       (declare ,times (Complex ,type -> Complex ,type -> Complex ,type))
-       (define (,times a b)
-         (lisp (Complex ,type) (a b)
-           (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
-           (cl:* a b)))
-
-       (specialize complex-divide ,divide (Complex ,type -> Complex ,type -> Complex ,type))
-       (declare ,divide (Complex ,type -> Complex ,type -> Complex ,type))
-       (define (,divide a b)
-         (lisp (Complex ,type) (a b)
-           (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
-           (cl:/ a b))))))
+             (cl:declare (cl:type (cl:or ,repr (cl:complex ,repr))))
+             (cl:/ a b)))))))
 
 (%define-native-complex-instances U8 (cl:unsigned-byte 8))
 (%define-native-complex-instances U16 (cl:unsigned-byte 16))

diff --git a/src/typechecker/define-instance.lisp b/src/typechecker/define-instance.lisp
@@ -301,6 +301,16 @@
     (when (eq *package* types-package)
       (return-from check-instance-valid))
 
+    ;; Allow definition of LispArray and Complex instances of RuntimeRepr
+    (when (member *package* (list (find-package "COALTON-LIBRARY/LISPARRAY")
+                                  (find-package "COALTON-LIBRARY/MATH/COMPLEX")))
+      (let ((types (parser:ty-predicate-types (parser:toplevel-define-instance-pred instance))))
+        (when (and (= 1 (length types))
+                   (parser:tapp-p (first types))
+                   (member (parser:tycon-name (parser:tapp-from (first types)))
+                           (list (find-symbol "COMPLEX" *package*)
+                                 (find-symbol "LISPARRAY" *package*)))))
+        (return-from check-instance-valid)))
 
     (when (eq (parser:identifier-src-name (parser:ty-predicate-class (parser:toplevel-define-instance-pred instance))) runtime-repr)
       (tc-error "Invalid instance"

diff --git a/src/typechecker/define-type.lisp b/src/typechecker/define-type.lisp
@@ -496,6 +496,13 @@
 (defun maybe-runtime-repr-instance (type)
   (declare (type type-definition type))
   (unless (or (equalp *package* (find-package "COALTON-LIBRARY/TYPES"))
+              ;; LispArray and Complex instance of RuntimeRepr are
+              ;; defined in the standard library as specialized
+              ;; native types.
+              (and (equalp *package* (find-package "COALTON-LIBRARY/LISPARRAY"))
+                   (eq (type-definition-name type) (find-symbol "LISPARRAY" *package*)))
+              (and (equalp *package* (find-package "COALTON-LIBRARY/MATH/COMPLEX"))
+                   (eq (type-definition-name type) (find-symbol "COMPLEX" *package*)))
               (type-definition-aliased-type type))
     (make-runtime-repr-instance type)))
 

diff --git a/tests/lisparray-tests.lisp b/tests/lisparray-tests.lisp
@@ -36,6 +36,9 @@
   (define array/single-float (array:make 10 0.0))
   (declare array/double-float (array:LispArray Double-Float))
   (define array/double-float (array:make 10 0.0d0))
+
+  (declare array/array/complex-single-float (array:LispArray (array:LispArray (math:Complex Single-Float))))
+  (define array/array/complex-single-float (array:make 10 (array:make 10 0)))
   )
 
 (define-test array-length ()
@@ -79,3 +82,12 @@
   (is (== (array:set! array/double-float 0 2.71828d0) Unit))
   (is (== (array:aref array/double-float 0) 2.71828d0))
   )
+
+(define-test nested-complex-array-test ()
+  (let ((ty (types:runtime-repr-of array/array/complex-single-float)))
+    (is (lisp Boolean (ty)
+          (cl:equal ty '(cl:simple-array
+                            (cl:simple-array
+                             (cl:complex cl:single-float)
+                             (cl:*))
+                            (cl:*)))))))