Derive specialized lisp types for transparent type

If a Coalton type is transparent type and specialized to a concrete
type, propagate the specialization when deriving lisp-type.
This enables underlying Lisp compiler to do more optimization.

Example: Suppose you have
```
(repr :transparent)
(define-type (Foo :t)
  (Foo (LispArray :t)))
```
Then, if you compute Lisp type of `(Foo Single-Float)`, it
returns `(simple-array single-float (*))`.

Author: shirok

coalton.asd

@@ -240,7 +240,8 @@
                (:file "runtime-tests")
                (:module "typechecker"
                 :serial t
-                :components ((:file "map-tests")))
+                :components ((:file "map-tests")
+                             (:file "lisp-type-tests")))
                (:file "environment-persist-tests")
                (:file "slice-tests")
                (:file "float-tests")

src/typechecker/lisp-type.lisp

@@ -102,7 +102,13 @@ USE-FUNCTION-ENTRIES specifies whether to emit FUNCTION-ENTRY for functions, emi
             (if (typep to 'tyvar)
                 `(cl:simple-array cl:* (cl:*))
                 `(cl:simple-array ,(lisp-type to env) (cl:*))))
-           
+
+           ;; When FROM is a transparent type, and we got a specialized type,
+           ;; we propagate parameterization to the inner type.
+           ((and (not (typep to 'tyvar))
+                 (try-recurse-transparent-type from to env)))
+
+
            ;; Otherwise we fall back.
            (t
             (lisp-type (tapp-from ty) env)))))
@@ -124,3 +130,51 @@ USE-FUNCTION-ENTRIES specifies whether to emit FUNCTION-ENTRY for functions, emi
   (:method ((ty qualified-ty) env)
     (lisp-type (qualified-ty-type ty) env)))
 
+
+(defun try-recurse-transparent-type (from parameter env)
+  "Called when taking a lisp-type of a parameterized type, where a
+concrete type is given to the parameter.  For example, a type `(Foo
+:t)` is defined, and we try to take a lisp-type of `(Foo UFix)`.  The
+`FROM` argument gets the type `Foo` and the `parameter` argument gets
+the type `UFix`.
+
+There is a special opportunity of optimization when `Foo` is defined
+as a transparent type, e.g. `(repr :transparent) (define-type (Foo
+:t) (Content (Lisparray :t)))`.  In that case, `(Foo UFix)` can have a
+Lisp type `(cl:simple-array cl:fixnum)`, which allows Lisp compiler to
+optimize further.  We check the conditions and returns a specialized
+Lisp type if possible.
+
+If we can't get a specialized Lisp type, this returns nil, and let the
+fallback branch take care of it.
+"
+  (labels ((transparent-type? (from)
+             (alexandria:when-let (entry (lookup-type env from :no-error t))
+               (eq (type-entry-explicit-repr entry) ':transparent)))
+           (reveal-underlying-type (from)
+             "If `from` type satisfies the optimizable condition, returns two
+values: the 'inner' type (wrappee type) and the 'outer' type (wrapper
+type)."
+             (let ((v (lookup-value-type env from :no-error t)))
+               (when (typep v 'ty-scheme)
+                 (let ((qt (qualified-ty-type (ty-scheme-type v))))
+                   ;; In transparent types, we have this in QT.
+                   ;; (Arrow <innter-type>) -> <outer-type>
+                   (when (function-type-p qt)
+                     (values (function-type-from qt)
+                             (function-type-to qt))))))))
+    (and (transparent-type? from)
+         (multiple-value-bind (inner outer) (reveal-underlying-type from)
+           (cond ((and (typep inner 'tycon)
+                       (typep outer 'tycon))
+                  (lisp-type inner env))
+                 ((and (typep inner 'tapp)
+                       (typep outer 'tapp)
+                       (typep (tapp-to inner) 'tgen)
+                       (eq (tapp-to inner) (tapp-to outer)))
+                  ;; Substitute inner type's type variable with the
+                  ;; concrete type
+                  (lisp-type (make-tapp :from (tapp-from inner)
+                                        :to parameter)
+                             env))
+                 (t nil))))))

tests/typechecker/lisp-type-tests.lisp

@@ -0,0 +1,67 @@
+(in-package #:coalton-native-tests)
+
+(coalton-toplevel
+  (repr :transparent)
+  (define-type (TransparentTypeTest :t)
+    (TransparentTypeTest (coalton-library/lisparray:LispArray :t)))
+
+  (declare complex-type-fn ((Complex :t) -> (Complex :t)))
+  (define (complex-type-fn x) x)
+
+  (declare complex-type-fn-1 ((Complex Double-Float) -> (Complex Double-Float)))
+  (define (complex-type-fn-1 x) x)
+
+  (declare lisp-array-fn ((coalton-library/lisparray:LispArray :t) -> :t))
+  (define (lisp-array-fn x)
+    (coalton-library/lisparray:aref x 0))
+
+  (declare lisp-array-fn-1 ((coalton-library/lisparray:LispArray IFix) -> IFix))
+  (define (lisp-array-fn-1 x)
+    (coalton-library/lisparray:aref x 0))
+
+  (declare transparent-type-fn ((TransparentTypeTest :t) -> :t))
+  (define (transparent-type-fn (TransparentTypeTest x))
+    (coalton-library/lisparray:aref x 0))
+
+  (declare transparent-type-fn-1 ((TransparentTypeTest IFix) -> IFix))
+  (define (transparent-type-fn-1 (TransparentTypeTest x))
+    (coalton-library/lisparray:aref x 0))
+  )
+
+(in-package #:coalton-tests)
+
+(deftest test-lisp-types ()
+  (let ((env coalton-impl/entry:*global-environment*))
+    (labels ((coalton-type (name)
+               (coalton-impl/typechecker/environment:type-entry-type
+                (coalton-impl/typechecker/environment:lookup-type env name)))
+             (coalton-type-of (value-name)
+               (coalton-impl/typechecker/environment:lookup-value-type env value-name))
+             (coalton-type-of-arg1 (value-name)
+               (car (coalton-impl/typechecker/types:function-type-arguments
+                     (coalton-type-of value-name))))
+             (lisp-type (coalton-type)
+               (coalton-impl/typechecker/lisp-type:lisp-type coalton-type env)))
+
+      ;; Concrete type mappings
+      (is (equal 'single-float (lisp-type (coalton-type 'coalton:single-float))))
+      (is (equal 'double-float (lisp-type (coalton-type 'coalton:double-float))))
+
+      ;; A few special cases
+      (is (equal '(or number coalton-library/math/complex:complex)
+                 (lisp-type (coalton-type-of-arg1 'coalton-native-tests::complex-type-fn))))
+      (is (equal '(complex double-float)
+                 (lisp-type (coalton-type-of-arg1 'coalton-native-tests::complex-type-fn-1))))
+      (is (equal '(simple-array * (*))
+                 (lisp-type (coalton-type-of-arg1 'coalton-native-tests::lisp-array-fn))))
+      (is (equal '(simple-array fixnum (*))
+                 (lisp-type (coalton-type-of-arg1 'coalton-native-tests::lisp-array-fn-1))))
+
+      ;; Transparent type
+      (is (equal 'coalton-impl/runtime/function-entry:function-entry
+                 (lisp-type (coalton-type-of 'coalton-native-tests::transparent-type-fn))))
+      (is (equal '(simple-array * (*))
+                 (lisp-type (coalton-type-of-arg1 'coalton-native-tests::transparent-type-fn))))
+      (is (equal '(simple-array fixnum (*))
+                 (lisp-type (coalton-type-of-arg1 'coalton-native-tests::transparent-type-fn-1))))
+      )))