Skip to content
Snippets Groups Projects
Commit 65fbb5c5 authored by toy's avatar toy
Browse files

Abstract all allocation through the ALLOCATION macro.

parent 40004fed
No related branches found
No related tags found
No related merge requests found
...@@ -5,11 +5,11 @@ ...@@ -5,11 +5,11 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.5 1995/02/27 00:51:49 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.6 2002/05/10 14:48:23 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.5 1995/02/27 00:51:49 wlott Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.6 2002/05/10 14:48:23 toy Exp $
;;; ;;;
;;; This file contains the support routines for arrays and vectors. ;;; This file contains the support routines for arrays and vectors.
;;; ;;;
...@@ -32,16 +32,21 @@ ...@@ -32,16 +32,21 @@
(:temp ndescr non-descriptor-reg nl0-offset) (:temp ndescr non-descriptor-reg nl0-offset)
(:temp vector descriptor-reg a3-offset)) (:temp vector descriptor-reg a3-offset))
(pseudo-atomic () (pseudo-atomic ()
(inst or vector alloc-tn vm:other-pointer-type)
(inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
(inst andn ndescr 7) (inst andn ndescr 7)
(inst add alloc-tn ndescr) (allocation vector ndescr other-pointer-type)
(inst srl ndescr type vm:word-shift) (inst srl ndescr type vm:word-shift)
(storew ndescr vector 0 vm:other-pointer-type) (storew ndescr vector 0 vm:other-pointer-type)
(storew length vector vm:vector-length-slot vm:other-pointer-type)) (storew length vector vm:vector-length-slot vm:other-pointer-type))
;; This makes sure the zero byte at the end of a string is paged in so ;; 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. ;; the kernel doesn't bitch if we pass it the string.
(storew zero-tn alloc-tn 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.
(storew zero-tn alloc-tn -1)
(move result vector)) (move result vector))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.12 2001/05/18 16:22:53 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.13 2002/05/10 14:48:23 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -46,9 +46,8 @@ ...@@ -46,9 +46,8 @@
temp))))) temp)))))
(let* ((cons-cells (if star (1- num) num)) (let* ((cons-cells (if star (1- num) num))
(alloc (* (pad-data-block cons-size) cons-cells))) (alloc (* (pad-data-block cons-size) cons-cells)))
(pseudo-atomic (:extra alloc) (pseudo-atomic ()
(inst andn res alloc-tn lowtag-mask) (allocation res alloc list-pointer-type)
(inst or res list-pointer-type)
(move ptr res) (move ptr res)
(dotimes (i (1- cons-cells)) (dotimes (i (1- cons-cells))
(storew (maybe-load (tn-ref-tn things)) ptr (storew (maybe-load (tn-ref-tn things)) ptr
...@@ -80,6 +79,7 @@ ...@@ -80,6 +79,7 @@
(unboxed-arg :scs (any-reg))) (unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) size)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed) (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
(:generator 100 (:generator 100
...@@ -92,9 +92,8 @@ ...@@ -92,9 +92,8 @@
;; Note: we don't have to subtract off the 4 that was added by ;; Note: we don't have to subtract off the 4 that was added by
;; pseudo-atomic, because oring in other-pointer-type just adds ;; pseudo-atomic, because oring in other-pointer-type just adds
;; it right back. ;; it right back.
(inst or result alloc-tn other-pointer-type) (inst add size boxed unboxed)
(inst add alloc-tn boxed) (allocation result size other-pointer-type)
(inst add alloc-tn unboxed)
(inst sll ndescr boxed (- type-bits word-shift)) (inst sll ndescr boxed (- type-bits word-shift))
(inst or ndescr code-header-type) (inst or ndescr code-header-type)
(storew ndescr result 0 other-pointer-type) (storew ndescr result 0 other-pointer-type)
...@@ -123,9 +122,8 @@ ...@@ -123,9 +122,8 @@
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:generator 10 (:generator 10
(let ((size (+ length closure-info-offset))) (let ((size (+ length closure-info-offset)))
(pseudo-atomic (:extra (pad-data-block size)) (pseudo-atomic ()
(inst andn result alloc-tn lowtag-mask) (allocation result (pad-data-block size) function-pointer-type)
(inst or result function-pointer-type)
(inst li temp (logior (ash (1- size) type-bits) closure-header-type)) (inst li temp (logior (ash (1- size) type-bits) closure-header-type))
(storew temp result 0 function-pointer-type))) (storew temp result 0 function-pointer-type)))
(storew function result closure-function-slot function-pointer-type))) (storew function result closure-function-slot function-pointer-type)))
...@@ -158,12 +156,8 @@ ...@@ -158,12 +156,8 @@
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (non-descriptor-reg)) temp)
(:generator 4 (:generator 4
(pseudo-atomic (:extra (pad-data-block words)) (pseudo-atomic ()
(cond ((logbitp (1- lowtag-bits) lowtag) (allocation result (pad-data-block words) lowtag)
(inst or result alloc-tn lowtag))
(t
(inst andn result alloc-tn lowtag-mask)
(inst or result lowtag)))
(when type (when type
(inst li temp (logior (ash (1- words) type-bits) type)) (inst li temp (logior (ash (1- words) type-bits) type))
(storew temp result 0 lowtag))))) (storew temp result 0 lowtag)))))
...@@ -175,6 +169,7 @@ ...@@ -175,6 +169,7 @@
(:ignore name) (:ignore name)
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:temporary (:scs (any-reg)) bytes header) (:temporary (:scs (any-reg)) bytes header)
(:temporary (:scs (descriptor-reg)) temp)
(:generator 6 (:generator 6
(inst add bytes extra (* (1+ words) word-bytes)) (inst add bytes extra (* (1+ words) word-bytes))
(inst sll header bytes (- type-bits 2)) (inst sll header bytes (- type-bits 2))
...@@ -182,11 +177,6 @@ ...@@ -182,11 +177,6 @@
(inst and bytes (lognot lowtag-mask)) (inst and bytes (lognot lowtag-mask))
(pseudo-atomic () (pseudo-atomic ()
;; Need to be careful if the lowtag and the pseudo-atomic flag ;; Need to be careful if the lowtag and the pseudo-atomic flag
;; are not compatible. ;; are not compatible
(cond ((logbitp (1- lowtag-bits) lowtag) (allocation result bytes lowtag)
(inst or result alloc-tn lowtag)) (storew header result 0 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))))
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.22 2001/05/18 16:22:53 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.23 2002/05/10 14:48:24 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -31,10 +31,9 @@ ...@@ -31,10 +31,9 @@
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:generator 0 (:generator 0
(pseudo-atomic () (pseudo-atomic ()
(inst or header alloc-tn other-pointer-type)
(inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes)) (inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
(inst andn ndescr 4) (inst andn ndescr 4)
(inst add alloc-tn ndescr) (allocation header ndescr other-pointer-type)
(inst add ndescr rank (fixnum (1- vm:array-dimensions-offset))) (inst add ndescr rank (fixnum (1- vm:array-dimensions-offset)))
(inst sll ndescr ndescr vm:type-bits) (inst sll ndescr ndescr vm:type-bits)
(inst or ndescr ndescr type) (inst or ndescr ndescr type)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/call.lisp,v 1.29 2001/09/25 21:28:04 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/call.lisp,v 1.30 2002/05/10 14:48:24 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -1189,12 +1189,11 @@ default-value-8 ...@@ -1189,12 +1189,11 @@ default-value-8
(pseudo-atomic () (pseudo-atomic ()
(assemble () (assemble ()
;; Allocate a cons (2 words) for each item. ;; Allocate a cons (2 words) for each item.
(inst andn result alloc-tn lowtag-mask)
(inst or result list-pointer-type)
(move dst result)
(inst sll temp count 1) (inst sll temp count 1)
(allocation result temp list-pointer-type)
(inst b enter) (inst b enter)
(inst add alloc-tn temp) (move dst result)
;; Compute the next cons and store it in the current one. ;; Compute the next cons and store it in the current one.
LOOP LOOP
......
...@@ -5,11 +5,11 @@ ...@@ -5,11 +5,11 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.15 2001/09/24 15:59:43 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.16 2002/05/10 14:48:24 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.15 2001/09/24 15:59:43 toy Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.16 2002/05/10 14:48:24 toy Exp $
;;; ;;;
;;; This file contains various useful macros for generating SPARC code. ;;; This file contains various useful macros for generating SPARC code.
;;; ;;;
...@@ -169,6 +169,28 @@ ...@@ -169,6 +169,28 @@
;;;; Storage allocation: ;;;; Storage allocation:
;; Allocation macro
;;
;; This macro does the appropriate stuff to allocate space.
;;
;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
;; applied. The amount of space to be allocated is SIZE bytes (which
;; must be a multiple of the lisp object size).
(defmacro allocation (result-tn size lowtag)
;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
;; set. If the lowtag also has a 1 bit in the same position, we're all
;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and
;; then or in the lowtag.
`(if (logbitp (1- lowtag-bits) ,lowtag)
(progn
(inst or ,result-tn alloc-tn ,lowtag)
(inst add alloc-tn ,size))
(progn
(inst andn ,result-tn alloc-tn lowtag-mask)
(inst or ,result-tn ,lowtag)
(inst add alloc-tn ,size))))
(defmacro with-fixed-allocation ((result-tn temp-tn type-code size) (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
&body body) &body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single "Do stuff to allocate an other-pointer object of fixed Size with a single
...@@ -178,8 +200,8 @@ ...@@ -178,8 +200,8 @@
initializes the object." initializes the object."
(once-only ((result-tn result-tn) (temp-tn temp-tn) (once-only ((result-tn result-tn) (temp-tn temp-tn)
(type-code type-code) (size size)) (type-code type-code) (size size))
`(pseudo-atomic (:extra (pad-data-block ,size)) `(pseudo-atomic ()
(inst or ,result-tn alloc-tn other-pointer-type) (allocation ,result-tn (pad-data-block ,size) other-pointer-type)
(inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 other-pointer-type) (storew ,temp-tn ,result-tn 0 other-pointer-type)
,@body))) ,@body)))
...@@ -466,7 +488,6 @@ ...@@ -466,7 +488,6 @@
,@forms ,@forms
;; Reset the pseudo-atomic flag ;; Reset the pseudo-atomic flag
(without-scheduling () (without-scheduling ()
#+nil (inst taddcctv alloc-tn (- ,n-extra 4))
;; Remove the pseudo-atomic flag ;; Remove the pseudo-atomic flag
(inst add alloc-tn (- ,n-extra 4)) (inst add alloc-tn (- ,n-extra 4))
;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1) ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment