Steel Bank Common Lisp

The branch "master" has been updated in SBCL:
       via  fd8e8143cf02ac767e2a46a2bc526933e68ef583 (commit)
      from  7d986ea35d26bbde3d8df8cc2580905b918aefef (commit)

- Log -----------------------------------------------------------------
commit fd8e8143cf02ac767e2a46a2bc526933e68ef583
Author: David Lichteblau <david@...>
Date:   Mon Oct 1 20:10:44 2012 +0200

    PowerPC safepoints
    
    "I saw it almost pass tests once.  Ship it."
    
    Rough PowerPC port of sb-safepoint and related features.  Occasional
    issues remain (see comment in test suite).
    
      - Sprinkle fake_foreign_function_call fairy dust over safepoint code.
    
      - Use the CSP page for synchronization, but not for its value.
    
      - No altstack, hence no tricks to escape from it.
    
      - Remove workarounds related to the SIGALRM handler; but keep
        SIGINT happy for now, with a somewhat less questionable check.
---
 src/code/target-signal.lisp  |   16 ++++++++++++
 src/compiler/ppc/c-call.lisp |    6 ++++-
 src/compiler/ppc/macros.lisp |    8 +++++-
 src/compiler/ppc/parms.lisp  |   29 ++++------------------
 src/compiler/ppc/system.lisp |    7 +++++
 src/runtime/gc-common.c      |    9 +++++-
 src/runtime/gc-internal.h    |    3 +-
 src/runtime/gencgc.c         |    8 ++++++
 src/runtime/interrupt.c      |   33 ++-----------------------
 src/runtime/ppc-assem.S      |   28 ++++++++++++++++++++-
 src/runtime/safepoint.c      |   55 +++++++++++++++++++++++++++++++++++++++++-
 src/runtime/thread.h         |   19 ++++++++++++--
 tests/threads.impure.lisp    |   17 ++++++++++---
 13 files changed, 170 insertions(+), 68 deletions(-)

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index feea1cf..9fab9d1 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -188,6 +188,22 @@
                  (signal int)
                  ;; Then enter the debugger like BREAK.
                  (%break 'sigint int))))))
+    #!+sb-safepoint
+    (let ((target (sb!thread::foreground-thread)))
+      ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
+      ;; interrupt right away, because deferrables are blocked.  Rather,
+      ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT
+      ;; handler is done.  However, on safepoint builds, we don't use
+      ;; SIGPIPE and lack an appropriate mechanism to handle pending
+      ;; thruptions upon exit from signal handlers (and this situation is
+      ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts
+      ;; explicitly at the end).  Only as long as safepoint builds pretend
+      ;; to cooperate with signals -- that is, as long as SIGINT-HANDLER
+      ;; is used at all -- detect this situation and work around it.
+      (if (eq target sb!thread:*current-thread*)
+          (interrupt-it)
+          (sb!thread:interrupt-thread target #'interrupt-it)))
+    #!-sb-safepoint
     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
                                 #'interrupt-it)))
 
diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp
index 2869883..4411684 100644
--- a/src/compiler/ppc/c-call.lisp
+++ b/src/compiler/ppc/c-call.lisp
@@ -660,7 +660,11 @@
               (inst stwu stack-pointer stack-pointer (- frame-size))
 
               ;; And make the call.
-              (load-address-into r0 (foreign-symbol-address "funcall3"))
+              (load-address-into
+               r0
+               (foreign-symbol-address
+                #!-sb-safepoint "funcall3"
+                #!+sb-safepoint "callback_wrapper_trampoline"))
               (inst mtlr r0)
               (inst blrl)
 
diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index c84757d..2fdfb7e 100644
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -353,7 +353,13 @@
      #+debug
      (progn
        (inst andi. ,flag-tn alloc-tn lowtag-mask)
-       (inst twi :ne ,flag-tn 0))))
+       (inst twi :ne ,flag-tn 0))
+     #!+sb-safepoint
+     (emit-safepoint)))
+
+#!+sb-safepoint
+(defun emit-safepoint ()
+  (inst lwz zero-tn null-tn (- (+ 4096 4 other-pointer-lowtag))))
 
 (def!macro with-pinned-objects ((&rest objects) &body body)
   "Arrange with the garbage collector that the pages occupied by
diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp
index a975b43..49b8cab 100644
--- a/src/compiler/ppc/parms.lisp
+++ b/src/compiler/ppc/parms.lisp
@@ -100,23 +100,16 @@
 
 ;;; While on gencgc we don't.
 #!+gencgc
-(progn
-  (def!constant read-only-space-start #x04000000)
-  (def!constant read-only-space-end   #x040ff000)
-  (def!constant static-space-start    #x04100000)
-  (def!constant static-space-end      #x041ff000)
-
-  (def!constant linkage-table-space-start #x04200000)
-  (def!constant linkage-table-space-end   #x042ff000))
+(!gencgc-space-setup #x04000000
+                     #!+linux   #x4f000000
+                     #!+netbsd  #x4f000000
+                     #!+openbsd #x4f000000
+                     #!+darwin  #x10000000)
 
 (def!constant linkage-table-entry-size 16)
 
 #!+linux
 (progn
-  #!+gencgc
-  (progn
-    (def!constant dynamic-space-start #x4f000000)
-    (def!constant dynamic-space-end   (!configure-dynamic-space-end)))
   #!-gencgc
   (progn
     (def!constant dynamic-0-space-start #x4f000000)
@@ -126,10 +119,6 @@
 
 #!+netbsd
 (progn
-  #!+gencgc
-  (progn
-    (def!constant dynamic-space-start #x4f000000)
-    (def!constant dynamic-space-end   (!configure-dynamic-space-end)))
   #!-gencgc
   (progn
     (def!constant dynamic-0-space-start #x4f000000)
@@ -146,10 +135,6 @@
 ;;; as rare as it might or might not be.
 #!+openbsd
 (progn
-  #!+gencgc
-  (progn
-    (def!constant dynamic-space-start #x4f000000)
-    (def!constant dynamic-space-end   (!configure-dynamic-space-end)))
   #!-gencgc
   (progn
     (def!constant dynamic-0-space-start #x4f000000)
@@ -159,10 +144,6 @@
 
 #!+darwin
 (progn
-  #!+gencgc
-  (progn
-    (def!constant dynamic-space-start #x10000000)
-    (def!constant dynamic-space-end   (!configure-dynamic-space-end)))
   #!-gencgc
   (progn
     (def!constant dynamic-0-space-start #x10000000)
diff --git a/src/compiler/ppc/system.lisp b/src/compiler/ppc/system.lisp
index 7fd20d8..ebaaca5 100644
--- a/src/compiler/ppc/system.lisp
+++ b/src/compiler/ppc/system.lisp
@@ -201,6 +201,13 @@
   (:generator 1
     (inst unimp pending-interrupt-trap)))
 
+#!+sb-safepoint
+(define-vop (insert-safepoint)
+  (:policy :fast-safe)
+  (:translate sb!kernel::gc-safepoint)
+  (:generator 0
+    (emit-safepoint)))
+
 #!+sb-thread
 (defknown current-thread-offset-sap ((unsigned-byte 64))
   system-area-pointer (flushable))
diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c
index 96ac8df..887337e 100644
--- a/src/runtime/gc-common.c
+++ b/src/runtime/gc-common.c
@@ -2718,9 +2718,14 @@ maybe_gc(os_context_t *context)
  * may be what the "lame" adjective in the above comment is for. In
  * this case, exact gc may lose badly. */
 void
-scrub_control_stack(void)
+scrub_control_stack()
+{
+    scrub_thread_control_stack(arch_os_get_current_thread());
+}
+
+void
+scrub_thread_control_stack(struct thread *th)
 {
-    struct thread *th = arch_os_get_current_thread();
     os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th);
     os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th);
 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h
index 1a72b88..d7123a4 100644
--- a/src/runtime/gc-internal.h
+++ b/src/runtime/gc-internal.h
@@ -158,7 +158,8 @@ lispobj *gc_search_space(lispobj *start, size_t words, lispobj *pointer);
 extern int looks_like_valid_lisp_pointer_p(lispobj pointer, lispobj *start_addr);
 
 extern void scavenge_control_stack(struct thread *th);
-extern void scrub_control_stack();
+extern void scrub_control_stack(void);
+extern void scrub_thread_control_stack(struct thread *);
 
 #include "fixnump.h"
 
diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
index 838bcac..c8defa3 100644
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -3543,10 +3543,18 @@ garbage_collect_generation(generation_index_t generation, int raise)
             scavenge_control_stack(th);
         }
 
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+        /* In this case, scrub all stacks r