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

Add support for dynamic-extent for ppc.

Simple tests with rest args and some dynamic-extent closures indicates
that this work.  Compiling CMUCL with dynamic-extent enabled appears
to work as well.  I conclude that the implementation here is probably
correct.

(Yes, I know dynamic-extent is currently disabled, but let's make ppc
complete.)

compiler/ppc/alloc.lisp:
o Implement the vops %DYNAMIC-EXTENT-START and %DYNAMIC-EXTENT-END.
o Update the LIST-OR-LIST*, MAKE-CLOSURE, and FIXED-ALLOC vops to
  support dynamic-extent, by passing ALLOCATION and
  WITH-FIXED-ALLOCATION macros the extra :STACK-P arg.

compiler/ppc/call.lisp:
o Update LISTIFY-REST-ARGS vop to support dynamic-extent, by passing
  the ALLOCATION macro the extra :STACK-P arg.

compiler/ppc/macros.lisp:
o Update the ALLOCATION macro to support the :STACK-P arg.
parent af09965a
No related branches found
No related tags found
No related merge requests found
...@@ -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.14 2006/01/18 15:21:26 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.15 2007/03/05 01:55:21 rtoy Rel $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -21,17 +21,35 @@ ...@@ -21,17 +21,35 @@
;;;; Dynamic-Extent (not implemented). ;;;; Dynamic-Extent (not implemented).
;;;
;;; Take an arg where to move the stack pointer instead of returning
;;; it via :results, because the former generates a single move.
;;;
(define-vop (%dynamic-extent-start) (define-vop (%dynamic-extent-start)
(:args (saved-stack-pointer :scs (any-reg))) (:args (saved-stack-pointer :scs (any-reg control-stack)))
(:results) (:results)
(:policy :safe) (:policy :safe)
(:generator 0)) (:generator 0
(sc-case saved-stack-pointer
(control-stack
(let ((offset (tn-offset saved-stack-pointer)))
(storew csp-tn cfp-tn offset)))
(any-reg
(move saved-stack-pointer csp-tn)))))
(define-vop (%dynamic-extent-end) (define-vop (%dynamic-extent-end)
(:args (saved-stack-pointer :scs (any-reg))) (:args (saved-stack-pointer :scs (any-reg control-stack)))
(:results) (:results)
(:policy :safe) (:policy :safe)
(:generator 0)) (:generator 0
(sc-case saved-stack-pointer
(control-stack
(let ((offset (tn-offset saved-stack-pointer)))
(loadw csp-tn cfp-tn offset)))
(any-reg
(move csp-tn saved-stack-pointer)))))
;;;; LIST and LIST* ;;;; LIST and LIST*
...@@ -67,7 +85,8 @@ ...@@ -67,7 +85,8 @@
(alloc (* (pad-data-block cons-size) cons-cells))) (alloc (* (pad-data-block cons-size) cons-cells)))
(pseudo-atomic (pa-flag) (pseudo-atomic (pa-flag)
(allocation res alloc list-pointer-type :temp-tn alloc-temp (allocation res alloc list-pointer-type :temp-tn alloc-temp
:flag-tn pa-flag) :flag-tn pa-flag
:stack-p dynamic-extent)
(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
...@@ -151,13 +170,13 @@ ...@@ -151,13 +170,13 @@
(:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:results (result :scs (descriptor-reg))) (:results (result :scs (descriptor-reg)))
(:ignore dynamic-extent)
(:generator 10 (:generator 10
(let ((size (+ length closure-info-offset))) (let ((size (+ length closure-info-offset)))
(pseudo-atomic (pa-flag) (pseudo-atomic (pa-flag)
(allocation result (pad-data-block size) function-pointer-type (allocation result (pad-data-block size) function-pointer-type
:temp-tn temp :flag-tn pa-flag) :temp-tn temp :flag-tn pa-flag
:stack-p dynamic-extent)
(inst lr temp (logior (ash (1- size) type-bits) closure-header-type)) (inst lr 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)))
...@@ -192,7 +211,8 @@ ...@@ -192,7 +211,8 @@
(:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:generator 4 (:generator 4
(with-fixed-allocation (result pa-flag temp type words :lowtag lowtag) (with-fixed-allocation (result pa-flag temp type words :lowtag lowtag
:stack-p dynamic-extent)
))) )))
(define-vop (var-alloc) (define-vop (var-alloc)
......
...@@ -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/call.lisp,v 1.15 2007/03/03 01:52:07 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/call.lisp,v 1.16 2007/03/05 01:55:22 rtoy Rel $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -1212,7 +1212,8 @@ default-value-8 ...@@ -1212,7 +1212,8 @@ default-value-8
(assemble () (assemble ()
;; Allocate a cons (2 words) for each item. ;; Allocate a cons (2 words) for each item.
(inst slwi temp count 1) (inst slwi temp count 1)
(allocation result temp list-pointer-type :temp-tn dst :flag-tn pa-flag) (allocation result temp list-pointer-type :temp-tn dst :flag-tn pa-flag
:stack-p dynamic-extent)
(move dst result) (move dst result)
(inst b enter) (inst b enter)
......
...@@ -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.12 2006/02/08 01:32:58 rtoy Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.13 2007/03/05 01:55:22 rtoy Rel $
;;; ;;;
;;; This file contains various useful macros for generating PC code. ;;; This file contains various useful macros for generating PC code.
;;; ;;;
...@@ -153,6 +153,7 @@ ...@@ -153,6 +153,7 @@
;; applied. The amount of space to be allocated is SIZE bytes (which ;; applied. The amount of space to be allocated is SIZE bytes (which
;; must be a multiple of the lisp object size). ;; must be a multiple of the lisp object size).
;; ;;
#+nil
(defmacro allocation (result-tn size lowtag &key stack-p temp-tn flag-tn) (defmacro allocation (result-tn size lowtag &key stack-p temp-tn flag-tn)
(declare (ignore stack-p) (declare (ignore stack-p)
#-gencgc #-gencgc
...@@ -203,9 +204,87 @@ ...@@ -203,9 +204,87 @@
(inst sub ,result-tn ,result-tn ,temp-tn) (inst sub ,result-tn ,result-tn ,temp-tn)
;; Set the lowtag appropriately ;; Set the lowtag appropriately
(inst ori ,result-tn ,result-tn ,lowtag)))) (inst ori ,result-tn ,result-tn ,lowtag))))
(defmacro allocation (result-tn size lowtag &key stack-p temp-tn flag-tn)
(declare #-gencgc
(ignore temp-tn flag-tn))
(let ((alloc-size (gensym)))
`(cond (,stack-p
;; Stack allocation
;;
;; The control stack grows up, so round up CSP to a
;; multiple of 8 (lispobj size). Use that as the
;; allocation pointer. Then add SIZE bytes to the
;; allocation and set CSP to that, so we have the desired
;; space.
;; Make sure the temp-tn is a non-descriptor register!
(assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg)))
;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size)
(inst li ,flag-tn vm:lowtag-mask)
(inst addi ,temp-tn csp-tn vm:lowtag-mask)
(inst andc ,temp-tn ,temp-tn ,flag-tn)
;; Set the result to temp-tn, with appropriate lowtag
(inst ori ,result-tn ,temp-tn ,lowtag)
;; Allocate the desired space on the stack.
;;
;; FIXME: Can't allocate on stack if SIZE is too large.
;; Need to rearrange this code.
(if (tn-p ,size)
(inst add csp-tn ,temp-tn ,size)
(inst addi csp-tn ,temp-tn ,size))
)
#-gencgc
(t
(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))))
#+gencgc
(t
;; Make temp-tn be the size
(cond ((numberp ,size)
(inst lr ,temp-tn ,size))
(t
(move ,temp-tn ,size)))
;; Get the end of the current allocation region.
(load-symbol-value ,flag-tn *current-region-end-addr*)
;; The object starts exactly where alloc-tn is, minus an tag
;; bits, etc.
;; CAUTION: The C code depends on the exact order of
;; instructions here. In particular, one instructions before
;; the TW instruction must be an ADD or ADDI instruction, so it
;; can figure out the size of the desired allocation.
(without-scheduling ()
;; Now make result-tn point at the end of the object, to
;; figure out if we overflowed the current region.
(inst add alloc-tn alloc-tn ,temp-tn)
(inst clrrwi ,result-tn alloc-tn lowtag-bits)
;; result-tn points to the new end of the region. Did we go past
;; the actual end of the region? If so, we need a full alloc.
;; The C code depends on this exact form of instruction. If
;; either changes, you have to change the other appropriately!
(inst tw :lge ,result-tn ,flag-tn))
;; At this point, result-tn points at the end of the object.
;; Adjust to point to the beginning.
(inst sub ,result-tn ,result-tn ,temp-tn)
;; Set the lowtag appropriately
(inst ori ,result-tn ,result-tn ,lowtag)))))
(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
&key (lowtag other-pointer-type)) &key (lowtag other-pointer-type)
stack-p)
&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
word header having the specified Type-Code. The result is placed in word header having the specified Type-Code. The result is placed in
...@@ -218,7 +297,8 @@ ...@@ -218,7 +297,8 @@
`(pseudo-atomic (,flag-tn) `(pseudo-atomic (,flag-tn)
(allocation ,result-tn (pad-data-block ,size) ,lowtag (allocation ,result-tn (pad-data-block ,size) ,lowtag
:temp-tn ,temp-tn :temp-tn ,temp-tn
:flag-tn ,flag-tn) :flag-tn ,flag-tn
:stack-p ,stack-p)
(when ,type-code (when ,type-code
(inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) (inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 ,lowtag)) (storew ,temp-tn ,result-tn 0 ,lowtag))
......
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