Fix make-array transforms.

[sbcl.git] / src / compiler / sparc / call.lisp

diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp
index 73b64c7..4f00c2d 100644 (file)
--- a/src/compiler/sparc/call.lisp
+++ b/src/compiler/sparc/call.lisp
@@ -16,7 +16,7 @@
 
 ;;; Return a wired TN describing the N'th full call argument passing
 ;;; location.
-(!def-vm-support-routine standard-arg-location (n)
+(defun standard-arg-location (n)
   (declare (type unsigned-byte n))
   (if (< n register-arg-count)
       (make-wired-tn *backend-t-primitive-type* register-arg-scn
@@ -29,7 +29,7 @@
 ;;; otherwise use any legal location.  Even in the non-standard case,
 ;;; this may be restricted by a desire to use a subroutine call
 ;;; instruction.
-(!def-vm-support-routine make-return-pc-passing-location (standard)
+(defun make-return-pc-passing-location (standard)
   (if standard
       (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset)
       (make-restricted-tn *backend-t-primitive-type* register-arg-scn)))
@@ -39,7 +39,7 @@
 ;;; standard convention, but is totally unrestricted in non-standard
 ;;; conventions, since we can always fetch it off of the stack using
 ;;; the arg pointer.
-(!def-vm-support-routine make-old-fp-passing-location (standard)
+(defun make-old-fp-passing-location (standard)
   (if standard
       (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
       (make-normal-tn *fixnum-primitive-type*)))
@@ -47,14 +47,14 @@
 ;;; Make the TNs used to hold Old-FP and Return-PC within the current
 ;;; function.  We treat these specially so that the debugger can find
 ;;; them at a known location.
-(!def-vm-support-routine make-old-fp-save-location (env)
+(defun make-old-fp-save-location (env)
   (specify-save-tn
    (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
    (make-wired-tn *fixnum-primitive-type*
                   control-stack-arg-scn
                   ocfp-save-offset)))
 
-(!def-vm-support-routine make-return-pc-save-location (env)
+(defun make-return-pc-save-location (env)
   (specify-save-tn
    (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
    (make-wired-tn *backend-t-primitive-type*
@@ -64,25 +64,25 @@
 ;;; Make a TN for the standard argument count passing location.  We
 ;;; only need to make the standard location, since a count is never
 ;;; passed when we are using non-standard conventions.
-(!def-vm-support-routine make-arg-count-location ()
+(defun make-arg-count-location ()
   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
 
 
 ;;; Make a TN to hold the number-stack frame pointer.  This is
 ;;; allocated once per component, and is component-live.
-(!def-vm-support-routine make-nfp-tn ()
+(defun make-nfp-tn ()
   (component-live-tn
    (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
 
-(!def-vm-support-routine make-stack-pointer-tn ()
+(defun make-stack-pointer-tn ()
   (make-normal-tn *fixnum-primitive-type*))
 
-(!def-vm-support-routine make-number-stack-pointer-tn ()
+(defun make-number-stack-pointer-tn ()
   (make-normal-tn *fixnum-primitive-type*))
 
 ;;; Return a list of TNs that can be used to represent an
 ;;; unknown-values continuation within a function.
-(!def-vm-support-routine make-unknown-values-locations ()
+(defun make-unknown-values-locations ()
   (list (make-stack-pointer-tn)
         (make-normal-tn *fixnum-primitive-type*)))
 
@@ -91,7 +91,7 @@
 ;;; VM-dependent initialization of the IR2-COMPONENT structure.  We push
 ;;; placeholder entries in the CONSTANTS to leave room for additional
 ;;; noise in the code object header.
-(!def-vm-support-routine select-component-format (component)
+(defun select-component-format (component)
   (declare (type component component))
   (dotimes (i code-constants-offset)
     (vector-push-extend nil
@@ -397,6 +397,15 @@ default-value-8
               nvals)
   (:temporary (:scs (non-descriptor-reg)) temp))
 
+\f
+;;; This hook in the codegen pass lets us insert code before fall-thru entry
+;;; points, local-call entry points, and tail-call entry points.  The default
+;;; does nothing.
+(defun emit-block-header (start-label trampoline-label fall-thru-p alignp)
+  (declare (ignore fall-thru-p alignp))
+  (when trampoline-label
+    (emit-label trampoline-label))
+  (emit-label start-label))
 
 \f
 ;;;; Local call with unknown values convention return:
@@ -1127,8 +1136,7 @@ default-value-8
     (let* ((enter (gen-label))
            (loop (gen-label))
            (done (gen-label))
-           (dx-p (node-stack-allocate-p node))
-           (alloc-area-tn (if dx-p csp-tn alloc-tn)))
+           (dx-p (node-stack-allocate-p node)))
       (move context context-arg)
       (move count count-arg)
       ;; Check to see if there are any arguments.
@@ -1138,15 +1146,13 @@ default-value-8
 
       ;; We need to do this atomically.
       (pseudo-atomic ()
-        (when dx-p
-          (align-csp temp))
         ;; Allocate a cons (2 words) for each item.
-        (inst andn result alloc-area-tn lowtag-mask)
-        (inst or result list-pointer-lowtag)
-        (move dst result)
         (inst sll temp count 1)
+        (allocation result temp list-pointer-lowtag
+                    :stack-p dx-p
+                    :temp-tn dst)
         (inst b enter)
-        (inst add alloc-area-tn temp)
+        (move dst result)
 
         ;; Compute the next cons and store it in the current one.
         (emit-label loop)