Replace ERROR compiler macro with transforms

Same logic as previous commit. I opted not to do the array OOB
condition since I'm not sure we actually signal it anywhere right
now. Maybe later.

Author: Bike

src/lisp/cscript.lisp

@@ -66,7 +66,6 @@
              #~"kernel/cmp/opt/opt-cons.lisp"
              #~"kernel/cmp/opt/opt-array.lisp"
              #~"kernel/cmp/opt/opt-object.lisp"
-             #~"kernel/cmp/opt/opt-condition.lisp"
              #~"kernel/cmp/opt/opt-print.lisp"
              #~"kernel/lsp/shiftf-rotatef.lisp"
              #~"kernel/lsp/assorted.lisp"

src/lisp/kernel/cleavir/bir-to-bmir.lisp

@@ -142,12 +142,21 @@
                            clasp-cleavir:*clasp-system*
                            header-type))))
 
+;; If CTYPE is an eql type (constant), return (constant t), else nil nil.
+(defun ctype-constant-value (ctype)
+  (let ((system clasp-cleavir:*clasp-system*))
+    (if (cleavir-ctype:member-p system ctype)
+        (let ((members (cleavir-ctype:member-members system ctype)))
+          (if (= (length members) 1)
+              (values (first members) t)
+              (values nil nil)))
+        (values nil nil))))
+
 (defun headerp-test (return-type object-type header-type)
   (declare (ignore return-type object-type))
-  (and (cleavir-ctype:member-p clasp-cleavir:*clasp-system* header-type)
-       (let ((h (first (cleavir-ctype:member-members
-                        clasp-cleavir:*clasp-system* header-type))))
-         (and (gethash h core:+type-header-value-map+) t))))
+  (multiple-value-bind (h constantp)
+      (ctype-constant-value header-type)
+    (and constantp (gethash h core:+type-header-value-map+) t)))
 
 (deftransform-f core::headerp #'compute-headerp-primop 'headerp-test (0)
   t t t)
@@ -171,6 +180,12 @@
 (deftransform random-state-p (core::headerq random-state) t)
 
 (deftransform core::etypecase-error core::etypecase-error t t)
+;; These are written kinda stupidly. Please forgive me.
+;; TODO: Better mechanism for &key parameters.
+(deftransform-f error (constantly 'type-error) (constantly t)
+  (2 4) t (eql type-error) (eql :datum) t (eql :expected-type) t)
+(deftransform-f error (constantly 'type-error) (constantly t)
+  (4 2) t (eql type-error) (eql :expected-type) t (eql :datum) t)
 
 (deftransform core:to-single-float core::double-to-single double-float)
 (deftransform core:to-single-float core::fixnum-to-single fixnum)
@@ -341,11 +356,9 @@
                '(t single-float double-float
                  base-char character))
        (cleavir-ctype:member-p system order-type)
-       (let ((mems (cleavir-ctype:member-members system order-type)))
-         (and (= (length mems) 1)
-              (member (first mems)
-                      '(:sequentially-consistent :relaxed
-                        :acquire-release :acquire :release))))))
+       (member (ctype-constant-value order-type)
+               '(:sequentially-consistent :relaxed
+                 :acquire-release :acquire :release))))
 
 (defun atomic-aref-test (return-type order-type array-type
                          &rest index-types)

src/lisp/kernel/cleavir/primop.lisp

@@ -130,6 +130,11 @@
 ;;; Particular primops
 ;;;
 
+(defvprimop-intrinsic type-error ((:object) :object :object)
+  "cc_error_type_error")
+(defvprimop-intrinsic core:array-out-of-bounds
+    ((:object) :object :object :object)
+  "cc_error_array_out_of_bounds")
 (defvprimop-intrinsic core::etypecase-error ((:object) :object :object)
   "cc_etypecase_error")