X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Fmacros.lisp;h=0a5e99140c232ed25d8ca03da25df6e8d6d88454;hb=94c003b32e49fc11a182d50c405ffa18183aa005;hp=5a2829547b03c789e6fb1322f225a8755a060fac;hpb=d294785c8e313384513208c1d93a44c3f22a0464;p=sbcl.git

diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp
index 5a28295..0a5e991 100644
--- a/src/compiler/hppa/macros.lisp
+++ b/src/compiler/hppa/macros.lisp
@@ -11,13 +11,25 @@
 (in-package "SB!VM")
 
 
-;;; Instruction-like macros.
 
-(defmacro move (src dst)
-  "Move SRC into DST unless they are location=."
-  (once-only ((src src) (dst dst))
-    `(unless (location= ,src ,dst)
-       (inst move ,src ,dst))))
+(defmacro expand (expr)
+  (let ((gensym (gensym)))
+    `(macrolet
+       ((,gensym ()
+           ,expr))
+       (,gensym))))
+
+;;; Instruction-like macros.
+;;; FIXME-lav: add if always-emit-code-p is :e= then error if location=
+(defmacro move (src dst &optional always-emit-code-p)
+  #!+sb-doc
+  "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)."
+  (once-only ((n-src src)
+              (n-dst dst))
+    `(if (location= ,n-dst ,n-src)
+       (when ,always-emit-code-p
+         (inst nop))
+       (inst move ,n-src ,n-dst))))
 
 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
   (once-only ((result result) (base base))
@@ -29,15 +41,20 @@
 
 (defmacro load-symbol (reg symbol)
   (once-only ((reg reg) (symbol symbol))
-    `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
+    `(let ((offset (static-symbol-offset ,symbol)))
+       (cond
+         ((typep offset '(signed-byte 11))
+           (inst addi offset null-tn ,reg))
+         (t
+           (inst ldil offset ,reg)
+           (inst ldo offset null-tn ,reg :unsigned t))))))
 
 (defmacro load-symbol-value (reg symbol)
   `(inst ldw
          (+ (static-symbol-offset ',symbol)
             (ash symbol-value-slot word-shift)
             (- other-pointer-lowtag))
-         null-tn
-         ,reg))
+         null-tn ,reg))
 
 (defmacro store-symbol-value (reg symbol)
   `(inst stw ,reg (+ (static-symbol-offset ',symbol)
@@ -46,41 +63,53 @@
          null-tn))
 
 (defmacro load-type (target source &optional (offset 0))
+  #!+sb-doc
   "Loads the type bits of a pointer into target independent of
-   byte-ordering issues."
-  (ecase *backend-byte-order*
-    (:little-endian
-     `(inst ldb ,offset ,source ,target))
-    (:big-endian
-     `(inst ldb (+ ,offset (1- n-word-bytes)) ,source ,target))))
+byte-ordering issues."
+  (once-only ((n-target target)
+              (n-source source)
+              (n-offset offset))
+    (ecase *backend-byte-order*
+      (:little-endian
+       `(inst ldb ,n-offset ,n-source ,n-target))
+      (:big-endian
+       `(inst ldb (+ ,n-offset (1- n-word-bytes)) ,n-source ,n-target)))))
+
+(defmacro set-lowtag (tag src dst)
+  `(progn
+     (inst move ,src ,dst)
+     (inst dep ,tag 31 n-lowtag-bits ,dst)))
 
 ;;; Macros to handle the fact that we cannot use the machine native call and
 ;;; return instructions.
 
 (defmacro lisp-jump (function)
-  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
+  #!+sb-doc
+  "Jump to the lisp function FUNCTION."
   `(progn
-     (inst addi
-           (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
-           ,function
-           lip-tn)
+     (inst addi (- (ash simple-fun-code-offset word-shift)
+                   fun-pointer-lowtag) ,function lip-tn)
      (inst bv lip-tn)
-     (move ,function code-tn)))
+     (move ,function code-tn t)))
 
 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
+  #!+sb-doc
   "Return to RETURN-PC."
   `(progn
      (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
            ,return-pc lip-tn)
      (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
-     ,@(when frob-code
-         `((move ,return-pc code-tn)))))
+     ,@(if frob-code
+         `((move ,return-pc code-tn t)))))
 
 (defmacro emit-return-pc (label)
+  #!+sb-doc
   "Emit a return-pc header word.  LABEL is the label to use for this
    return-pc."
   `(progn
-     (align n-lowtag-bits)
+     ;; alignment causes the return point to land on two address,
+     ;; where the first must be nop pad.
+     (emit-alignment n-lowtag-bits)
      (emit-label ,label)
      (inst lra-header-word)))
 
@@ -95,6 +124,7 @@
        (sc-case stack
          ((control-stack)
           (loadw reg cfp-tn offset))))))
+
 (defmacro store-stack-tn (stack reg)
   `(let ((stack ,stack)
          (reg ,reg))
@@ -104,6 +134,7 @@
           (storew reg cfp-tn offset))))))
 
 (defmacro maybe-load-stack-tn (reg reg-or-stack)
+  #!+sb-doc
   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
   (once-only ((n-reg reg)
               (n-stack reg-or-stack))
@@ -118,27 +149,53 @@
 
 ;;;; Storage allocation:
 
-(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code
+                                  size dynamic-extent-p
+                                  &key (lowtag other-pointer-lowtag)
+                                       maybe-write)
                                  &body body)
+  #!+sb-doc
   "Do stuff to allocate an other-pointer object of fixed Size with a single
-  word header having the specified Type-Code.  The result is placed in
-  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
-  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
-  initializes the object."
-  (unless body
-    (bug "empty &body in WITH-FIXED-ALLOCATION"))
+word header having the specified Type-Code.  The result is placed in
+Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
+by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
+initializes the object."
+  (declare (ignore flag-tn))
   (once-only ((result-tn result-tn) (temp-tn temp-tn)
-              (type-code type-code) (size size))
-    `(pseudo-atomic (:extra (pad-data-block ,size))
-       (inst move alloc-tn ,result-tn)
-       (inst dep other-pointer-lowtag 31 3 ,result-tn)
-       (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
-       (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
-       ,@body)))
+              (type-code type-code) (size size)
+              (lowtag lowtag))
+    (let ((write-body `((inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
+                        (storew ,temp-tn ,result-tn 0 ,lowtag))))
+      `(if ,dynamic-extent-p
+         (pseudo-atomic ()
+           (align-csp ,temp-tn)
+           (set-lowtag ,lowtag csp-tn ,result-tn)
+           (inst addi (pad-data-block ,size) csp-tn csp-tn)
+           ,@(if maybe-write
+               `((when ,type-code ,@write-body))
+               write-body)
+           ,@body)
+         (pseudo-atomic (:extra (pad-data-block ,size))
+           (set-lowtag ,lowtag alloc-tn ,result-tn)
+           ,@(if maybe-write
+               `((when ,type-code ,@write-body))
+               write-body)
+           ,@body)))))
+
+;;; is used for stack allocation of dynamic-extent objects
+;;; FIXME-lav, if using defun, atleast surround in assembly-form ? macro better ?
+(defun align-csp (temp)
+  (declare (ignore temp))
+  (let ((aligned (gen-label)))
+    (inst extru csp-tn 31 n-lowtag-bits zero-tn :<>)
+    (inst b aligned :nullify t)
+    (inst addi n-word-bytes csp-tn csp-tn)
+    (storew zero-tn csp-tn -1)
+    (emit-label aligned)))
 
 
 ;;;; Error Code
-(eval-when (compile load eval)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
       `((let ((vop ,vop))
@@ -157,22 +214,26 @@
           (inst byte (length ,vector))
           (dotimes (i (length ,vector))
             (inst byte (aref ,vector i))))
-        (align word-shift)))))
+        (emit-alignment word-shift)))))
 
 (defmacro error-call (vop error-code &rest values)
+  #!+sb-doc
   "Cause an error.  ERROR-CODE is the error to cause."
   (cons 'progn
         (emit-error-break vop error-trap error-code values)))
 
 
 (defmacro cerror-call (vop label error-code &rest values)
+  #!+sb-doc
   "Cause a continuable error.  If the error is continued, execution resumes at
   LABEL."
   `(progn
-     (inst b ,label)
-     ,@(emit-error-break vop cerror-trap error-code values)))
+     (without-scheduling ()
+       (inst b ,label)
+       ,@(emit-error-break vop cerror-trap error-code values))))
 
 (defmacro generate-error-code (vop error-code &rest values)
+  #!+sb-doc
   "Generate-Error-Code Error-code Value*
   Emit code for an error with the specified Error-Code and context Values."
   `(assemble (*elsewhere*)
@@ -182,6 +243,7 @@
        start-lab)))
 
 (defmacro generate-cerror-code (vop error-code &rest values)
+  #!+sb-doc
   "Generate-CError-Code Error-code Value*
   Emit code for a continuable error with the specified Error-Code and
   context Values.  If the error is continued, execution resumes after
@@ -224,15 +286,15 @@
        ,@(when translate
            `((:translate ,translate)))
        (:policy :fast-safe)
-       (:args (object :scs (descriptor-reg) :to (:eval 0))
-              (index :scs (any-reg) :target temp))
+       (:args (object :scs (descriptor-reg))
+              (index :scs (any-reg)))
        (:arg-types ,type tagged-num)
-       (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
+       (:temporary (:scs (interior-reg)) lip)
        (:results (value :scs ,scs))
        (:result-types ,el-type)
        (:generator 5
-         (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
-         (inst ldwx temp object value)))
+         (inst add object index lip)
+         (loadw value lip ,offset ,lowtag)))
      (define-vop (,(symbolicate name "-C"))
        ,@(when translate
            `((:translate ,translate)))
@@ -245,8 +307,7 @@
        (:results (value :scs ,scs))
        (:result-types ,el-type)
        (:generator 4
-         (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
-               object value)))))
+         (loadw value object (+ ,offset index) ,lowtag)))))
 
 (defmacro define-full-setter (name type offset lowtag scs el-type
                                    &optional translate)
@@ -264,7 +325,7 @@
        (:result-types ,el-type)
        (:generator 2
          (inst add object index lip)
-         (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
+         (storew value lip ,offset ,lowtag)
          (move value result)))
      (define-vop (,(symbolicate name "-C"))
        ,@(when translate
@@ -280,7 +341,7 @@
        (:results (result :scs ,scs))
        (:result-types ,el-type)
        (:generator 1
-         (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
+         (storew value object (+ ,offset index) ,lowtag)
          (move value result)))))
 
 
@@ -375,3 +436,4 @@ garbage collection.  This is currently implemented by disabling GC"
   (declare (ignore objects))            ;should we eval these for side-effect?
   `(without-gcing
     ,@body))
+