From 37a9a1acdb9f9d6bd91b8420fc7fb351b44b11e9 Mon Sep 17 00:00:00 2001
From: Alastair Bridgewater <nyef@lain.lisphacker.com>
Date: Tue, 23 Apr 2013 13:23:01 -0400
Subject: [PATCH] ppc: Implement :stack-allocatable-fixed-objects

  * Alter SYS:SRC;COMPILER;PPC;MACROS.LISP, WITH-FIXED-ALLOCATION
to accept a parameter for requesting stack allocation instead of
heap allocation.

  * Alter SYS:SRC;COMPILER;PPC;ALLOC.LISP, VOP FIXED-ALLOC to pass
the new stack-allocation parameter.

  * And add :stack-allocatable-fixed-objects to the PPC section in
make-config.sh.
---
 make-config.sh               |    3 ++-
 src/compiler/ppc/alloc.lisp  |    6 ++++--
 src/compiler/ppc/macros.lisp |   14 ++++++++++----
 3 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/make-config.sh b/make-config.sh
index 6b720e0..6a0e6f4 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -613,7 +613,8 @@ elif [ "$sbcl_arch" = "mips" ]; then
     printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf
     printf ' :alien-callbacks' >> $ltf
 elif [ "$sbcl_arch" = "ppc" ]; then
-    printf ' :gencgc :stack-allocatable-closures :stack-allocatable-lists' >> $ltf
+    printf ' :gencgc :stack-allocatable-closures' >> $ltf
+    printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf
     printf ' :linkage-table :raw-instance-init-vops :memory-barrier-vops' >> $ltf
     printf ' :compare-and-swap-vops :multiply-high-vops' >> $ltf
     if [ "$sbcl_os" = "linux" ]; then
diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
index 0656963..f903dd4 100644
--- a/src/compiler/ppc/alloc.lisp
+++ b/src/compiler/ppc/alloc.lisp
@@ -177,12 +177,14 @@
 (define-vop (fixed-alloc)
   (:args)
   (:info name words type lowtag stack-allocate-p)
-  (:ignore name stack-allocate-p)
+  (:ignore name)
   (:results (result :scs (descriptor-reg)))
   (: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-allocate-p stack-allocate-p)
       )))
 
 (define-vop (var-alloc)
diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index 262cc10..4fb7160 100644
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -265,7 +265,8 @@
        (inst ori ,result-tn ,result-tn ,lowtag)))
 
 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
-                                            &key (lowtag other-pointer-lowtag))
+                                            &key (lowtag other-pointer-lowtag)
+                                                 stack-allocate-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
@@ -275,9 +276,14 @@
   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
               (type-code type-code) (size size) (lowtag lowtag))
     `(pseudo-atomic (,flag-tn)
-       (allocation ,result-tn (pad-data-block ,size) ,lowtag
-                   :temp-tn ,temp-tn
-                   :flag-tn ,flag-tn)
+       (if ,stack-allocate-p
+           (progn
+             (align-csp ,temp-tn)
+             (inst ori ,result-tn csp-tn ,lowtag)
+             (inst addi csp-tn csp-tn (pad-data-block ,size)))
+         (allocation ,result-tn (pad-data-block ,size) ,lowtag
+                     :temp-tn ,temp-tn
+                     :flag-tn ,flag-tn))
        (when ,type-code
          (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
          (storew ,temp-tn ,result-tn 0 ,lowtag))
-- 
1.7.10.4