Revert "SPARC gencgc"

This reverts commit 1d06300.

CREDITS

@@ -850,7 +850,6 @@ PRM  Pierre Mai
 PVE  Peter Van Eynde
 PW   Paul Werkowski
 RAM  Robert MacLachlan
-RLT  Raymond Toy
 TCR  Tobias Rittweiler
 THS  Thiemo Seufer
 VJA  Vincent Arkesteijn

make-config.sh

@@ -622,17 +622,7 @@ elif [ "$sbcl_arch" = "sparc" ]; then
     # FUNCDEF macro for assembler. No harm in running this on sparc-linux
     # as well.
     sh tools-for-build/sparc-funcdef.sh > src/runtime/sparc-funcdef.h
-    if [ "$sbcl_os" = "sunos" ]; then
-        printf ' :gencgc' >> $ltf
-    else
-        echo '***'
-        echo '*** You are running SPARC on non-SunOS.  Since GENCGC is'
-        echo '*** untested on this combination, make-config.sh is falling'
-        echo '*** back to CHENEYGC.  Please consider adjusting parms.lisp'
-        echo '*** to build with GENCGC instead.'
-        echo '***'
-        printf ' :cheneygc' >> $ltf
-    fi
+    printf ' :cheneygc' >> $ltf
     if [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "linux" ]; then
         printf ' :linkage-table' >> $ltf
     fi

package-data-list.lisp-expr

@@ -2588,7 +2588,6 @@ structure representations"
                "%COMPILER-BARRIER" "%DATA-DEPENDENCY-BARRIER"
                "%MEMORY-BARRIER" "%READ-BARRIER" "%WRITE-BARRIER"
                "AFTER-BREAKPOINT-TRAP"
-               #!+(and gencgc sparc) "ALLOCATION-TRAP"
                "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET"
                "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT"
                "ARRAY-DISPLACED-FROM-SLOT"
@@ -2680,8 +2679,8 @@ structure representations"
                "GENCGC-CARD-BYTES"
                "GENCGC-ALLOC-GRANULARITY"
                "GENCGC-RELEASE-GRANULARITY"
-               #!+(or ppc sparc) "PSEUDO-ATOMIC-INTERRUPTED-FLAG"
-               #!+(or ppc sparc) "PSEUDO-ATOMIC-FLAG"
+               #!+ppc "PSEUDO-ATOMIC-INTERRUPTED-FLAG"
+               #!+ppc "PSEUDO-ATOMIC-FLAG"
                #!+sb-safepoint "GLOBAL-SAFEPOINT-TRAP"
                "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
                "IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER"

src/assembly/sparc/arith.lisp

@@ -171,12 +171,31 @@
   (inst srl lo n-fixnum-tag-bits)
   (inst or lo temp)
   (inst sra hi n-fixnum-tag-bits)
+  ;; Allocate a BIGNUM for the result.
+  #+nil
+  (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
+                 (let ((one-word (gen-label)))
+                   (inst or res alloc-tn other-pointer-lowtag)
+                   ;; We start out assuming that we need one word.  Is that correct?
+                   (inst sra temp lo 31)
+                   (inst xorcc temp hi)
+                   (inst b :eq one-word)
+                   (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+                   ;; Nope, we need two, so allocate the addition space.
+                   (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
+                                         (pad-data-block (1+ bignum-digits-offset))))
+                   (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+                   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
+                   (emit-label one-word)
+                   (storew temp res 0 other-pointer-lowtag)
+                   (storew lo res bignum-digits-offset other-pointer-lowtag)))
   ;; Always allocate 2 words for the bignum result, even if we only
   ;; need one.  The copying GC will take care of the extra word if it
   ;; isn't needed.
   (with-fixed-allocation
       (res temp bignum-widetag (+ 2 bignum-digits-offset))
     (let ((one-word (gen-label)))
+      (inst or res alloc-tn other-pointer-lowtag)
       ;; We start out assuming that we need one word.  Is that correct?
       (inst sra temp lo 31)
       (inst xorcc temp hi)

src/assembly/sparc/array.lisp

@@ -23,34 +23,17 @@
                           (:res result descriptor-reg a0-offset)
 
                           (:temp ndescr non-descriptor-reg nl0-offset)
-                          (:temp gc-temp non-descriptor-reg nl1-offset)
                           (:temp vector descriptor-reg a3-offset))
   (pseudo-atomic ()
+    (inst or vector alloc-tn other-pointer-lowtag)
     ;; boxed words == unboxed bytes
     (inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
     (inst andn ndescr 7)
-    (allocation vector ndescr other-pointer-lowtag :temp-tn gc-temp)
+    (inst add alloc-tn ndescr)
     (inst srl ndescr type word-shift)
     (storew ndescr vector 0 other-pointer-lowtag)
     (storew length vector vector-length-slot other-pointer-lowtag))
   ;; This makes sure the zero byte at the end of a string is paged in so
   ;; the kernel doesn't bitch if we pass it the string.
-  ;;
-  ;; RLT comments in CMUCL about changing the following line to
-  ;; store at -1 instead of 0:
-  ;;   This used to write to the word after the last allocated word.  I
-  ;;   (RLT) made it write to the last allocated word, which is where
-  ;;   the zero-byte of the string is.  Look at the deftransform for
-  ;;   make-array in array-tran.lisp.  For strings we always allocate
-  ;;   enough space to hold the zero-byte.
-  ;; Which is most certainly motivated by the fact that this store (if
-  ;; performed on gencgc) overwrites the first word of the following
-  ;; page -- destroying the first object of an unrelated allocation region!
-  ;;
-  ;; But the CMUCL fix breaks :ELEMENT-TYPE NIL strings, so we'd need a
-  ;; branch to figure out whether to do it.  Until and unless someone
-  ;; demonstrates that gencgc actually gives us uncommitted memory, I'm
-  ;; just not doing it at all:  -- DFL
-  #!-gencgc
   (storew zero-tn alloc-tn 0)
   (move result vector))

src/cold/shared.lisp

@@ -153,7 +153,7 @@
           ":GENCGC and :CHENEYGC are incompatible")
          ("(and cheneygc (not (or alpha hppa mips ppc sparc)))"
           ":CHENEYGC not supported on selected architecture")
-         ("(and gencgc (not (or sparc ppc x86 x86-64)))"
+         ("(and gencgc (not (or ppc x86 x86-64)))"
           ":GENCGC not supported on selected architecture")
          ("(not (or gencgc cheneygc))"
           "One of :GENCGC or :CHENEYGC must be enabled")

src/compiler/sparc/alloc.lisp

@@ -18,7 +18,6 @@
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
               res)
-  (:temporary (:scs (non-descriptor-reg)) alloc-temp)
   (:info num)
   (:results (result :scs (descriptor-reg)))
   (:variant-vars star)
@@ -42,10 +41,14 @@
              (let* ((dx-p (node-stack-allocate-p node))
                     (cons-cells (if star (1- num) num))
                     (alloc (* (pad-data-block cons-size) cons-cells)))
-               (pseudo-atomic ()
-                 (allocation res alloc list-pointer-lowtag
-                             :stack-p dx-p
-                             :temp-tn alloc-temp)
+               (pseudo-atomic (:extra (if dx-p 0 alloc))
+                 (let ((allocation-area-tn (if dx-p csp-tn alloc-tn)))
+                   (when dx-p
+                     (align-csp res))
+                   (inst andn res allocation-area-tn lowtag-mask)
+                   (inst or res list-pointer-lowtag)
+                   (when dx-p
+                     (inst add csp-tn csp-tn alloc)))
                  (move ptr res)
                  (dotimes (i (1- cons-cells))
                    (storew (maybe-load (tn-ref-tn things)) ptr
@@ -78,7 +81,6 @@
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) ndescr)
   (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
-  (:temporary (:scs (non-descriptor-reg)) size)
   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
   (:generator 100
     (inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot)))
@@ -87,16 +89,15 @@
     (inst add unboxed lowtag-mask)
     (inst and unboxed (lognot lowtag-mask))
     (pseudo-atomic ()
+      ;; CMUCL Comment:
+      ;; Note: we don't have to subtract off the 4 that was added by
+      ;; pseudo-atomic, because oring in other-pointer-lowtag just adds
+      ;; it right back.
       ;;
       ;; This looks like another dreadful type pun. CSR - 2002-02-06
-      ;;
-      ;; Not any more, or not in that sense at least, because the
-      ;; "p/a bit is also the highest lowtag bit" assumption is now hidden
-      ;; in the allocation macro.  DFL - 2012-10-01
-      ;;
-      ;; Figure out how much space we really need and allocate it.
-      (inst add size boxed unboxed)
-      (allocation result size other-pointer-lowtag :temp-tn ndescr)
+      (inst or result alloc-tn other-pointer-lowtag)
+      (inst add alloc-tn boxed)
+      (inst add alloc-tn unboxed)
       (inst sll ndescr boxed (- n-widetag-bits word-shift))
       (inst or ndescr code-header-widetag)
       (storew ndescr result 0 other-pointer-lowtag)
@@ -126,10 +127,15 @@
   (:generator 10
     (let* ((size (+ length closure-info-offset))
            (alloc-size (pad-data-block size)))
-      (pseudo-atomic ()
-        (allocation result alloc-size fun-pointer-lowtag
-                    :stack-p stack-allocate-p
-                    :temp-tn temp)
+      (pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size))
+        (cond (stack-allocate-p
+               (align-csp temp)
+               (inst andn result csp-tn lowtag-mask)
+               (inst or result fun-pointer-lowtag)
+               (inst add csp-tn alloc-size))
+              (t
+               (inst andn result alloc-tn lowtag-mask)
+               (inst or result fun-pointer-lowtag)))
         (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
         (storew temp result 0 fun-pointer-lowtag)
         (storew function result closure-fun-slot fun-pointer-lowtag)))))
@@ -167,8 +173,12 @@
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 4
-    (pseudo-atomic ()
-      (allocation result (pad-data-block words) lowtag :temp-tn temp)
+    (pseudo-atomic (:extra (pad-data-block words))
+      (cond ((logbitp (1- n-lowtag-bits) lowtag)
+             (inst or result alloc-tn lowtag))
+            (t
+             (inst andn result alloc-tn lowtag-mask)
+             (inst or result lowtag)))
       (when type
         (inst li temp (logior (ash (1- words) n-widetag-bits) type))
         (storew temp result 0 lowtag)))))
@@ -181,12 +191,18 @@
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (any-reg)) bytes)
   (:temporary (:scs (non-descriptor-reg)) header)
-  (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 6
     (inst add bytes extra (* (1+ words) n-word-bytes))
     (inst sll header bytes (- n-widetag-bits 2))
     (inst add header header (+ (ash -2 n-widetag-bits) type))
     (inst and bytes (lognot lowtag-mask))
     (pseudo-atomic ()
-      (allocation result bytes lowtag :temp-tn temp)
-      (storew header result 0 lowtag))))
+      ;; Need to be careful if the lowtag and the pseudo-atomic flag
+      ;; are not compatible.
+      (cond ((logbitp (1- n-lowtag-bits) lowtag)
+             (inst or result alloc-tn lowtag))
+            (t
+             (inst andn result alloc-tn lowtag-mask)
+             (inst or result lowtag)))
+      (storew header result 0 lowtag)
+      (inst add alloc-tn alloc-tn bytes))))

src/compiler/sparc/array.lisp

@@ -20,14 +20,14 @@
   (:arg-types tagged-num tagged-num)
   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
   (:temporary (:scs (non-descriptor-reg)) ndescr)
-  (:temporary (:scs (non-descriptor-reg)) gencgc-temp)
   (:results (result :scs (descriptor-reg)))
   (:generator 0
     (pseudo-atomic ()
+      (inst or header alloc-tn other-pointer-lowtag)
       (inst add ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
                                lowtag-mask))
       (inst andn ndescr lowtag-mask)
-      (allocation header ndescr other-pointer-lowtag :temp-tn gencgc-temp)
+      (inst add alloc-tn ndescr)
       (inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
       (inst sll ndescr ndescr n-widetag-bits)
       (inst or ndescr ndescr type)

src/compiler/sparc/backend-parms.lisp

@@ -23,18 +23,5 @@
 
 (setf *backend-byte-order* :big-endian)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (setf *backend-page-bytes* 8192))
+(setf *backend-page-bytes* 8192)
 
-;;; The size in bytes of GENCGC cards, i.e. the granularity at which
-;;; writes to old generations are logged.  With mprotect-based write
-;;; barriers, this must be a multiple of the OS page size.
-(def!constant gencgc-card-bytes *backend-page-bytes*)
-;;; The minimum size of new allocation regions.  While it doesn't
-;;; currently make a lot of sense to have a card size lower than
-;;; the alloc granularity, it will, once we are smarter about finding
-;;; the start of objects.
-(def!constant gencgc-alloc-granularity 0)
-;;; The minimum size at which we release address ranges to the OS.
-;;; This must be a multiple of the OS page size.
-(def!constant gencgc-release-granularity *backend-page-bytes*)

src/compiler/sparc/call.lisp

@@ -1136,7 +1136,8 @@ default-value-8
     (let* ((enter (gen-label))
            (loop (gen-label))
            (done (gen-label))
-           (dx-p (node-stack-allocate-p node)))
+           (dx-p (node-stack-allocate-p node))
+           (alloc-area-tn (if dx-p csp-tn alloc-tn)))
       (move context context-arg)
       (move count count-arg)
       ;; Check to see if there are any arguments.
@@ -1146,13 +1147,15 @@ 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)
-        (move dst result)
+        (inst add alloc-area-tn temp)
 
         ;; Compute the next cons and store it in the current one.
         (emit-label loop)