Skip to content
Snippets Groups Projects
Commit a90bef30 authored by rtoy's avatar rtoy
Browse files

Define allocation macro to handle allocation. Use it. (Incomplete,

but everything should still work.)
parent 1b3a21ca
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.2 2003/08/03 11:27:51 gerd Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.3 2004/08/08 11:15:11 rtoy Exp $
;;; ;;;
;;; This file contains the support routines for arrays and vectors. ;;; This file contains the support routines for arrays and vectors.
;;; ;;;
...@@ -31,10 +31,9 @@ ...@@ -31,10 +31,9 @@
(:temp pa-flag non-descriptor-reg nl3-offset) (:temp pa-flag non-descriptor-reg nl3-offset)
(:temp vector descriptor-reg a3-offset)) (:temp vector descriptor-reg a3-offset))
(pseudo-atomic (pa-flag) (pseudo-atomic (pa-flag)
(inst ori vector alloc-tn vm:other-pointer-type)
(inst addi ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) (inst addi ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
(inst clrrwi ndescr ndescr lowtag-bits) (inst clrrwi ndescr ndescr lowtag-bits)
(inst add alloc-tn alloc-tn ndescr) (allocation vector ndescr other-pointer-type)
(inst srwi ndescr type vm:word-shift) (inst srwi 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))
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.5 2004/07/25 18:15:52 pmai Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.6 2004/08/08 11:15:11 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -43,6 +43,7 @@ ...@@ -43,6 +43,7 @@
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
res) res)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:temporary (:scs (non-descriptor-reg)) alloc-temp)
(:info num dynamic-extent) (:info num dynamic-extent)
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:variant-vars star) (:variant-vars star)
...@@ -64,9 +65,8 @@ ...@@ -64,9 +65,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 (pa-flag :extra alloc) (pseudo-atomic (pa-flag)
(inst clrrwi res alloc-tn lowtag-bits) (allocation res alloc list-pointer-type :temp-tn alloc-temp)
(inst ori res 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
...@@ -98,6 +98,7 @@ ...@@ -98,6 +98,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)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
...@@ -111,9 +112,8 @@ ...@@ -111,9 +112,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 ori result alloc-tn other-pointer-type) (inst add size boxed unboxed)
(inst add alloc-tn alloc-tn boxed) (allocation result size other-pointer-type :temp-tn ndescr)
(inst add alloc-tn alloc-tn unboxed)
(inst slwi ndescr boxed (- type-bits word-shift)) (inst slwi ndescr boxed (- type-bits word-shift))
(inst ori ndescr ndescr code-header-type) (inst ori ndescr ndescr code-header-type)
(storew ndescr result 0 other-pointer-type) (storew ndescr result 0 other-pointer-type)
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.4 2004/07/25 18:15:52 pmai Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.5 2004/08/08 11:15:12 rtoy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -29,13 +29,13 @@ ...@@ -29,13 +29,13 @@
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) gc-temp) ; gencgc
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:generator 0 (:generator 0
(pseudo-atomic (pa-flag) (pseudo-atomic (pa-flag)
(inst ori header alloc-tn other-pointer-type)
(inst addi ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes)) (inst addi ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
(inst clrrwi ndescr ndescr lowtag-bits) (inst clrrwi ndescr ndescr lowtag-bits)
(inst add alloc-tn alloc-tn ndescr) (allocation header ndescr other-pointer-type :temp-tn gc-temp)
(inst addi ndescr rank (fixnumize (1- vm:array-dimensions-offset))) (inst addi ndescr rank (fixnumize (1- vm:array-dimensions-offset)))
(inst slwi ndescr ndescr vm:type-bits) (inst slwi ndescr ndescr vm:type-bits)
(inst or ndescr ndescr type) (inst or ndescr ndescr type)
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.2 2004/07/25 18:15:52 pmai Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.3 2004/08/08 11:15:12 rtoy Exp $
;;; ;;;
;;; This file contains various useful macros for generating PC code. ;;; This file contains various useful macros for generating PC code.
;;; ;;;
...@@ -165,6 +165,21 @@ ...@@ -165,6 +165,21 @@
;;;; Storage allocation: ;;;; Storage allocation:
(defmacro allocation (result-tn size lowtag &key stack-p temp-tn)
(declare (ignore stack-p temp-tn))
(let ((alloc-size (gensym)))
`(let ((,alloc-size ,size))
(if (logbitp (1- lowtag-bits) ,lowtag)
(progn
(inst ori ,result-tn alloc-tn ,lowtag))
(progn
(inst clrrwi ,result-tn alloc-tn lowtag-bits)
(inst ori ,result-tn ,result-tn ,lowtag)))
(if (numberp ,alloc-size)
(inst addi alloc-tn alloc-tn ,alloc-size)
(inst add alloc-tn alloc-tn ,alloc-size)))))
#+nil
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size) (defmacro with-fixed-allocation ((result-tn flag-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
...@@ -180,6 +195,24 @@ ...@@ -180,6 +195,24 @@
(storew ,temp-tn ,result-tn 0 other-pointer-type) (storew ,temp-tn ,result-tn 0 other-pointer-type)
,@body))) ,@body)))
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
&key (lowtag other-pointer-type))
&body body)
"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."
(once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
(type-code type-code) (size size))
`(pseudo-atomic (,flag-tn)
(allocation ,result-tn (pad-data-block ,size) ,lowtag
:temp-tn temp-tn)
(when ,type-code
(inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 other-pointer-type))
,@body)))
;;;; Type testing noise. ;;;; Type testing noise.
......
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