Changeset 14335

Timestamp:

Oct 7, 2010, 10:46:30 AM (14 years ago)

Author:

Gary Byers

Message:

Optionally (mostly optional for bootstrapping reasons) expect the
backend to handle %ILOGNOT, ASH (in the latter case, by trying to
do something other than a subprim call, if possible.)

File:

• trunk/source/compiler/nx1.lisp (modified) (1 diff)

trunk/source/compiler/nx1.lisp

@@ -2230 +2230 @@
   (make-acode (%nx1-default-operator) (nx1-form arg)))
 
-
+(defnx1 nx1-%ilognot (%ilognot) (n)
+  ;; Bootstrapping nonsense.
+  (if (aref (backend-p2-dispatch *target-backend*)
+            (logand operator-id-mask (%nx1-operator %ilognot)))
+    (make-acode (%nx1-operator typed-form)
+                'fixnum
+                (make-acode (%nx1-operator %ilognot)
+                            (nx1-form n)))
+    (nx1-form (macroexpand `(%ilognot ,n)))))
+
+    
 (defnx1 nx1-ash (ash) (&whole call &environment env num amt)
-  (let* ((unsigned-natural-type (target-word-size-case
-                                 (32 '(unsigned-byte 32))
-                                 (64 '(unsigned-byte 64))))
-         (max (target-word-size-case (32 32) (64 64)))
-         (maxbits (target-word-size-case
-                   (32 29)
-                   (64 60))))
-    (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
-          ((and (fixnump amt)
-                (< amt 0))
-           (if (nx-form-typep num 'fixnum env)
-             (make-acode (%nx1-operator %iasr)
-                         (make-acode (%nx1-operator fixnum)
-                                     (- amt))
-                         (nx1-form num))
-             (if (nx-form-typep num unsigned-natural-type env)
-               (if (< (- amt) max)
-                 (make-acode (%nx1-operator natural-shift-right)
-                             (nx1-form num)
-                             (make-acode (%nx1-operator fixnum)
-                                         (- amt)))
-                 (nx1-form `(progn (require-type ,num 'integer) 0) env))
+  (flet ((defer-to-backend ()
+             ;; Bootstrapping nonsense
+             (if (svref (backend-p2-dispatch *target-backend*)
+                        (logand operator-id-mask (%nx1-operator ash)))
+               (make-acode (%nx1-operator typed-form)
+                           'integer
+                           (make-acode
+                            (%nx1-operator ash)
+                            (nx1-form num)
+                            (nx1-form amt)))
                (nx1-treat-as-call call))))
-          ((and (fixnump amt)
-                (<= 0 amt maxbits)
-                (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env)
-                    (and (nx-form-typep num 'fixnum env)
-                         (nx-trust-declarations env)
-                         (subtypep *nx-form-type* 'fixnum))))
-           (nx1-form `(%ilsl ,amt ,num)))
-          ((and (fixnump amt)
-                (< amt max)
-                (nx-form-typep num unsigned-natural-type env)
-                (nx-trust-declarations env)
-                (subtypep *nx-form-type* unsigned-natural-type))
-           (make-acode (%nx1-operator natural-shift-left)
-                       (nx1-form num)
-                       (nx1-form amt)))
-          ((fixnump num)
-           (let* ((field-width (1+ (integer-length num)))
-                  ;; num fits in a `(signed-byte ,field-width)
-                  (max-shift (- (1+ maxbits) field-width)))
-             (if (nx-form-typep amt `(mod ,(1+ max-shift)) env)
-               (nx1-form `(%ilsl ,amt ,num))
-               (nx1-treat-as-call call))))
-          (t (nx1-treat-as-call call)))))
+    (let* ((unsigned-natural-type (target-word-size-case
+                                   (32 '(unsigned-byte 32))
+                                   (64 '(unsigned-byte 64)))) 
+           (max (target-word-size-case (32 32) (64 64)))
+           (maxbits (target-word-size-case
+                     (32 29)
+                     (64 60))))
+      (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
+            ((and (fixnump amt)
+                  (< amt 0))
+             (if (nx-form-typep num 'fixnum env)
+               (make-acode (%nx1-operator %iasr)
+                           (make-acode (%nx1-operator fixnum)
+                                       (- amt))
+                           (nx1-form num))
+               (if (nx-form-typep num unsigned-natural-type env)
+                 (if (< (- amt) max)
+                   (make-acode (%nx1-operator natural-shift-right)
+                               (nx1-form num)
+                               (make-acode (%nx1-operator fixnum)
+                                           (- amt)))
+                   (nx1-form `(progn (require-type ,num 'integer) 0) env))
+                 (defer-to-backend))))
+            ((and (fixnump amt)
+                  (<= 0 amt maxbits)
+                  (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env)
+                      (and (nx-form-typep num 'fixnum env)
+                           (nx-trust-declarations env)
+                           (subtypep *nx-form-type* 'fixnum))))
+             (nx1-form `(%ilsl ,amt ,num)))
+            ((and (fixnump amt)
+                  (< 0 amt max)
+                  (nx-form-typep num unsigned-natural-type env)
+                  (nx-trust-declarations env)
+                  (subtypep *nx-form-type* unsigned-natural-type))
+             (make-acode (%nx1-operator natural-shift-left)
+                         (nx1-form num)
+                         (nx1-form amt)))
+            ((fixnump num)
+             (let* ((field-width (1+ (integer-length num)))
+                    ;; num fits in a `(signed-byte ,field-width)
+                    (max-shift (- (1+ maxbits) field-width)))
+               (if (nx-form-typep amt `(mod ,(1+ max-shift)) env)
+                 (nx1-form `(%ilsl ,amt ,num))
+                 (defer-to-backend))))
+            (t (defer-to-backend))))))