disassemble: Better annotation of static functions and safepoints.
[sbcl.git] / src / compiler / mips / cell.lisp
index 1151b6c..04689c3 100644 (file)
@@ -1,5 +1,16 @@
-(in-package "SB!VM")
+;;;; the VM definition of various primitive memory access VOPs for
+;;;; MIPS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
 
+(in-package "SB!VM")
 \f
 ;;;; Data object ref/set stuff.
 
 
 (define-vop (set-slot)
   (:args (object :scs (descriptor-reg))
-        (value :scs (descriptor-reg any-reg null zero)))
+         (value :scs (descriptor-reg any-reg null zero)))
   (:info name offset lowtag)
   (:ignore name)
   (:results)
   (:generator 1
     (storew value object offset lowtag)))
 
+(define-vop (init-slot set-slot))
 \f
 ;;;; Symbol hacking VOPs:
 
@@ -49,7 +61,7 @@
     (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
       (inst xor temp value unbound-marker-widetag)
-      (inst beq temp zero-tn err-lab)
+      (inst beq temp err-lab)
       (inst nop))))
 
 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
@@ -67,8 +79,8 @@
     (loadw value object symbol-value-slot other-pointer-lowtag)
     (inst xor temp value unbound-marker-widetag)
     (if not-p
-       (inst beq temp zero-tn target)
-       (inst bne temp zero-tn target))
+        (inst beq temp target)
+        (inst bne temp target))
     (inst nop)))
 
 (define-vop (fast-symbol-value cell-ref)
   (:policy :fast)
   (:translate symbol-value))
 
+(define-vop (symbol-hash)
+  (:policy :fast-safe)
+  (:translate symbol-hash)
+  (:args (symbol :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (res :scs (any-reg)))
+  (:result-types positive-fixnum)
+  (:generator 2
+    ;; The symbol-hash slot of NIL holds NIL because it is also the
+    ;; cdr slot, so we have to strip off the two low bits to make sure
+    ;; it is a fixnum.  The lowtag selection magic that is required to
+    ;; ensure this is explained in the comment in objdef.lisp
+    (loadw temp symbol symbol-hash-slot other-pointer-lowtag)
+    (inst srl temp n-fixnum-tag-bits)
+    (inst sll res temp n-fixnum-tag-bits)))
+
+;;; On unithreaded builds these are just copies of the non-global versions.
+(define-vop (%set-symbol-global-value set))
+(define-vop (symbol-global-value symbol-value)
+  (:translate symbol-global-value))
+(define-vop (fast-symbol-global-value fast-symbol-value)
+  (:translate symbol-global-value))
 \f
 ;;;; Fdefinition (fdefn) objects.
 
   (:policy :fast-safe)
   (:translate (setf fdefn-fun))
   (:args (function :scs (descriptor-reg) :target result)
-        (fdefn :scs (descriptor-reg)))
+         (fdefn :scs (descriptor-reg)))
   (:temporary (:scs (interior-reg)) lip)
   (:temporary (:scs (non-descriptor-reg)) type)
   (:results (result :scs (descriptor-reg)))
       (load-type type function (- fun-pointer-lowtag))
       (inst nop)
       (inst xor type simple-fun-header-widetag)
-      (inst beq type zero-tn normal-fn)
+      (inst beq type normal-fn)
       (inst addu lip function
-           (- (ash simple-fun-code-offset word-shift)
-              fun-pointer-lowtag))
+            (- (ash simple-fun-code-offset word-shift)
+               fun-pointer-lowtag))
       (inst li lip (make-fixup "closure_tramp" :foreign))
       (emit-label normal-fn)
       (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
 
 (define-vop (bind)
   (:args (val :scs (any-reg descriptor-reg))
-        (symbol :scs (descriptor-reg)))
+         (symbol :scs (descriptor-reg)))
   (:temporary (:scs (descriptor-reg)) temp)
   (:generator 5
     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst addu bsp-tn bsp-tn (* -2 n-word-bytes))))
 
 
   (:temporary (:scs (descriptor-reg)) symbol value)
   (:generator 0
     (let ((loop (gen-label))
-         (skip (gen-label))
-         (done (gen-label)))
+          (skip (gen-label))
+          (done (gen-label)))
       (move where arg)
       (inst beq where bsp-tn done)
       (inst nop)
 
       (emit-label loop)
       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
-      (inst beq symbol zero-tn skip)
+      (inst beq symbol skip)
       (loadw value bsp-tn (- binding-value-slot binding-size))
       (storew value symbol symbol-value-slot other-pointer-lowtag)
       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
       (emit-label skip)
+      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (inst addu bsp-tn bsp-tn (* -2 n-word-bytes))
       (inst bne where bsp-tn loop)
       (inst nop)
   funcallable-instance-info-offset fun-pointer-lowtag
   (descriptor-reg any-reg) * %funcallable-instance-info)
 
-(define-vop (funcallable-instance-lexenv cell-ref)
-  (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
-
 (define-vop (closure-ref slot-ref)
   (:variant closure-info-offset fun-pointer-lowtag))
 
 (define-vop (closure-init slot-set)
   (:variant closure-info-offset fun-pointer-lowtag))
 
+(define-vop (closure-init-from-fp)
+  (:args (object :scs (descriptor-reg)))
+  (:info offset)
+  (:generator 4
+    (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
 \f
 ;;;; Value Cell hackery.
 
   (:policy :fast-safe)
   (:translate %instance-length)
   (:args (struct :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
   (:results (res :scs (unsigned-reg)))
   (:result-types positive-fixnum)
   (:generator 4
-    (loadw res struct 0 instance-pointer-lowtag)
-    (inst srl res n-widetag-bits)))
-
-(define-vop (instance-ref slot-ref)
-  (:variant instance-slots-offset instance-pointer-lowtag)
-  (:policy :fast-safe)
-  (:translate %instance-ref)
-  (:arg-types instance (:constant index)))
-
-#+nil
-(define-vop (instance-set slot-set)
-  (:policy :fast-safe)
-  (:translate %instance-set)
-  (:variant instance-slots-offset instance-pointer-lowtag)
-  (:arg-types instance (:constant index) *))
+    (loadw temp struct 0 instance-pointer-lowtag)
+    (inst srl res temp n-widetag-bits)))
 
 (define-full-reffer instance-index-ref * instance-slots-offset
   instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
   (descriptor-reg any-reg null zero) * code-header-set)
 
 
+\f
+;;;; raw instance slot accessors
 
+(define-vop (raw-instance-ref/word)
+  (:translate %raw-instance-ref/word)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (value :scs (unsigned-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types unsigned-num)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset n-word-bytes)
+    (inst addu lip offset object)
+    (inst lw value lip (- (* instance-slots-offset n-word-bytes)
+                          instance-pointer-lowtag))))
+
+(define-vop (raw-instance-set/word)
+  (:translate %raw-instance-set/word)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg))
+         (value :scs (unsigned-reg) :target result))
+  (:arg-types * positive-fixnum unsigned-num)
+  (:results (result :scs (unsigned-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types unsigned-num)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset n-word-bytes)
+    (inst addu lip offset object)
+    (inst sw value lip (- (* instance-slots-offset n-word-bytes)
+                          instance-pointer-lowtag))
+    (move result value)))
+
+(define-vop (raw-instance-ref/single)
+  (:translate %raw-instance-ref/single)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (value :scs (single-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types single-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset n-word-bytes)
+    (inst addu lip offset object)
+    (inst lwc1 value lip (- (* instance-slots-offset n-word-bytes)
+                            instance-pointer-lowtag))))
+
+(define-vop (raw-instance-set/single)
+  (:translate %raw-instance-set/single)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg))
+         (value :scs (single-reg) :target result))
+  (:arg-types * positive-fixnum single-float)
+  (:results (result :scs (single-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types single-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset n-word-bytes)
+    (inst addu lip offset object)
+    (inst swc1 value lip (- (* instance-slots-offset n-word-bytes)
+                            instance-pointer-lowtag))
+    (unless (location= result value)
+      (inst fmove :single result value))))
+
+(define-vop (raw-instance-ref/double)
+  (:translate %raw-instance-ref/double)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (value :scs (double-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types double-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset (* 2 n-word-bytes))
+    (inst addu lip offset object)
+    (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst lwc1 value lip immediate-offset))
+        (:little-endian (inst lwc1-odd value lip immediate-offset))))
+    (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst lwc1-odd value lip immediate-offset))
+        (:little-endian (inst lwc1 value lip immediate-offset))))))
+
+(define-vop (raw-instance-set/double)
+  (:translate %raw-instance-set/double)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg))
+         (value :scs (double-reg) :target result))
+  (:arg-types * positive-fixnum double-float)
+  (:results (result :scs (double-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types double-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset (* 2 n-word-bytes))
+    (inst addu lip offset object)
+    (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst swc1 value lip immediate-offset))
+        (:little-endian (inst swc1-odd value lip immediate-offset))))
+    (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst swc1-odd value lip immediate-offset))
+        (:little-endian (inst swc1 value lip immediate-offset))))
+    (unless (location= result value)
+      (inst fmove :double result value))))
+
+(define-vop (raw-instance-ref/complex-single)
+  (:translate %raw-instance-ref/complex-single)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (value :scs (complex-single-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types complex-single-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset (* 2 n-word-bytes))
+    (inst addu lip offset object)
+    (inst lwc1
+          (complex-single-reg-real-tn value)
+          lip
+          (- (* instance-slots-offset n-word-bytes)
+             instance-pointer-lowtag))
+    (inst lwc1
+          (complex-single-reg-imag-tn value)
+          lip
+          (- (* (1+ instance-slots-offset) n-word-bytes)
+             instance-pointer-lowtag))))
+
+(define-vop (raw-instance-set/complex-single)
+  (:translate %raw-instance-set/complex-single)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg))
+         (value :scs (complex-single-reg) :target result))
+  (:arg-types * positive-fixnum complex-single-float)
+  (:results (result :scs (complex-single-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types complex-single-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset (* 2 n-word-bytes))
+    (inst addu lip offset object)
+    (let ((value-real (complex-single-reg-real-tn value))
+          (result-real (complex-single-reg-real-tn result)))
+      (inst swc1
+            value-real
+            lip
+            (- (* instance-slots-offset n-word-bytes)
+               instance-pointer-lowtag))
+      (unless (location= result-real value-real)
+        (inst fmove :single result-real value-real)))
+    (let ((value-imag (complex-single-reg-imag-tn value))
+          (result-imag (complex-single-reg-imag-tn result)))
+      (inst swc1
+            value-imag
+            lip
+            (- (* (1+ instance-slots-offset) n-word-bytes)
+               instance-pointer-lowtag))
+      (unless (location= result-imag value-imag)
+        (inst fmove :single result-imag value-imag)))))
+
+(define-vop (raw-instance-ref/complex-double)
+  (:translate %raw-instance-ref/complex-double)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg)))
+  (:arg-types * positive-fixnum)
+  (:results (value :scs (complex-double-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types complex-double-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset (* 4 n-word-bytes))
+    (inst addu lip offset object)
+    (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst lwc1
+                           (complex-double-reg-real-tn value)
+                           lip
+                           immediate-offset))
+        (:little-endian (inst lwc1-odd
+                              (complex-double-reg-real-tn value)
+                              lip
+                              immediate-offset))))
+    (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst lwc1-odd
+                           (complex-double-reg-real-tn value)
+                           lip
+                           immediate-offset))
+        (:little-endian (inst lwc1
+                              (complex-double-reg-real-tn value)
+                              lip
+                              immediate-offset))))
+    (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst lwc1
+                           (complex-double-reg-imag-tn value)
+                           lip
+                           immediate-offset))
+        (:little-endian (inst lwc1-odd
+                              (complex-double-reg-imag-tn value)
+                              lip
+                              immediate-offset))))
+    (let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes)
+                               instance-pointer-lowtag)))
+      (ecase *backend-byte-order*
+        (:big-endian (inst lwc1-odd
+                           (complex-double-reg-imag-tn value)
+                           lip
+                           immediate-offset))
+        (:little-endian (inst lwc1
+                              (complex-double-reg-imag-tn value)
+                              lip
+                              immediate-offset))))))
+
+(define-vop (raw-instance-set/complex-double)
+  (:translate %raw-instance-set/complex-double)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+         (index :scs (any-reg))
+         (value :scs (complex-double-reg) :target result))
+  (:arg-types * positive-fixnum complex-double-float)
+  (:results (result :scs (complex-double-reg)))
+  (:temporary (:scs (non-descriptor-reg)) offset)
+  (:temporary (:scs (interior-reg)) lip)
+  (:result-types complex-double-float)
+  (:generator 5
+    (loadw offset object 0 instance-pointer-lowtag)
+    (inst srl offset n-widetag-bits)
+    (inst sll offset n-fixnum-tag-bits)
+    (inst subu offset index)
+    (inst subu offset (* 4 n-word-bytes))
+    (inst addu lip offset object)
+    (let ((value-real (complex-double-reg-real-tn value))
+          (result-real (complex-double-reg-real-tn result)))
+      (let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
+                                 instance-pointer-lowtag)))
+        (ecase *backend-byte-order*
+          (:big-endian (inst swc1
+                             value-real
+                             lip
+                             immediate-offset))
+          (:little-endian (inst swc1-odd
+                                value-real
+                                lip
+                                immediate-offset))))
+      (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
+                                 instance-pointer-lowtag)))
+        (ecase *backend-byte-order*
+          (:big-endian (inst swc1-odd
+                             value-real
+                             lip
+                             immediate-offset))
+          (:little-endian (inst swc1
+                                value-real
+                                lip
+                                immediate-offset))))
+      (unless (location= result-real value-real)
+        (inst fmove :double result-real value-real)))
+    (let ((value-imag (complex-double-reg-imag-tn value))
+          (result-imag (complex-double-reg-imag-tn result)))
+      (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
+                                 instance-pointer-lowtag)))
+        (ecase *backend-byte-order*
+          (:big-endian (inst swc1
+                             value-imag
+                             lip
+                             immediate-offset))
+          (:little-endian (inst swc1-odd
+                                value-imag
+                                lip
+                                immediate-offset))))
+      (let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes)
+                                 instance-pointer-lowtag)))
+        (ecase *backend-byte-order*
+          (:big-endian (inst swc1-odd
+                             value-imag
+                             lip
+                             immediate-offset))
+          (:little-endian (inst swc1
+                                value-imag
+                                lip
+                                immediate-offset))))
+      (unless (location= result-imag value-imag)
+        (inst fmove :double result-imag value-imag)))))