From c17bd546197abd785d00fd9c10f3f09b9b9b0abe Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Mon, 5 Mar 2007 01:55:22 +0000
Subject: [PATCH] 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.
---
 compiler/ppc/alloc.lisp  | 38 +++++++++++++-----
 compiler/ppc/call.lisp   |  5 ++-
 compiler/ppc/macros.lisp | 86 ++++++++++++++++++++++++++++++++++++++--
 3 files changed, 115 insertions(+), 14 deletions(-)

diff --git a/compiler/ppc/alloc.lisp b/compiler/ppc/alloc.lisp
index 64b2b9a23..60e5f686e 100644
--- a/compiler/ppc/alloc.lisp
+++ b/compiler/ppc/alloc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (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 @@
 
 ;;;; 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)
-  (:args (saved-stack-pointer :scs (any-reg)))
+  (:args (saved-stack-pointer :scs (any-reg control-stack)))
   (:results)
   (: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)
-  (:args (saved-stack-pointer :scs (any-reg)))
+  (:args (saved-stack-pointer :scs (any-reg control-stack)))
   (:results)
   (: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*
@@ -67,7 +85,8 @@
 		    (alloc (* (pad-data-block cons-size) cons-cells)))
 	       (pseudo-atomic (pa-flag)
 		 (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)
 		 (dotimes (i (1- cons-cells))
 		   (storew (maybe-load (tn-ref-tn things)) ptr
@@ -151,13 +170,13 @@
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
   (:results (result :scs (descriptor-reg)))
-  (:ignore dynamic-extent)
   (:generator 10
     (let ((size (+ length closure-info-offset)))
       (pseudo-atomic (pa-flag)
      
 	(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))
 	(storew temp result 0 function-pointer-type)))
     (storew function result closure-function-slot function-pointer-type)))
@@ -192,7 +211,8 @@
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
   (: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)
diff --git a/compiler/ppc/call.lisp b/compiler/ppc/call.lisp
index fdbc0047e..bd07939aa 100644
--- a/compiler/ppc/call.lisp
+++ b/compiler/ppc/call.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (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
       (assemble ()
 	;; Allocate a cons (2 words) for each item.
 	(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)
 	(inst b enter)
 
diff --git a/compiler/ppc/macros.lisp b/compiler/ppc/macros.lisp
index 342ff45c3..d774bda2f 100644
--- a/compiler/ppc/macros.lisp
+++ b/compiler/ppc/macros.lisp
@@ -7,7 +7,7 @@
 ;;; 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.
 ;;;
@@ -153,6 +153,7 @@
 ;; applied.  The amount of space to be allocated is SIZE bytes (which
 ;; must be a multiple of the lisp object size).
 ;;
+#+nil
 (defmacro allocation (result-tn size lowtag &key stack-p temp-tn flag-tn)
   (declare (ignore stack-p)
 	   #-gencgc
@@ -203,9 +204,87 @@
       (inst sub ,result-tn ,result-tn ,temp-tn)
       ;; Set the lowtag appropriately
       (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
-					    &key (lowtag other-pointer-type))
+					    &key (lowtag other-pointer-type)
+					    stack-p)
 				 &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
@@ -218,7 +297,8 @@
     `(pseudo-atomic (,flag-tn)
        (allocation ,result-tn (pad-data-block ,size) ,lowtag
 		   :temp-tn ,temp-tn
-	           :flag-tn ,flag-tn)
+	           :flag-tn ,flag-tn
+                   :stack-p ,stack-p)
        (when ,type-code
 	 (inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
 	 (storew ,temp-tn ,result-tn 0 ,lowtag))
-- 
GitLab