Steel Bank Common Lisp

The branch "master" has been updated in SBCL:
       via  bf40ae88bc289fd765a33861cc4bc0853ed483ba (commit)
      from  2b29a7c2b236cfab1d4d06311e84414abba71b4c (commit)

- Log -----------------------------------------------------------------
commit bf40ae88bc289fd765a33861cc4bc0853ed483ba
Author: David Lichteblau <david@...>
Date:   Wed Dec 26 15:39:34 2012 +0100

    Fix attach_thread to allocate a TLS index for *gc-inhibit* if needed
    
    Instead of occasionally setting a global value for this variable...
    
    Thanks to Stas Boukarev for the bug report.
---
 src/runtime/thread.c |    2 +-
 1 files changed, 1 insertions(+), 1 deletions(-)

diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 46f8f7d..26f6de6 100644
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -535,7 +535,7 @@ attach_os_thread(init_thread_data *scribble)
      * tempting to just perform such unsafe allocation though.  So let's
      * at least try to suppress GC before consing, and hope that it
      * works: */
-    SetSymbolValue(GC_INHIBIT, T, th);
+    bind_variable(GC_INHIBIT, T, th);
 
     uword_t stacksize
         = (uword_t) th->control_stack_end - (uword_t) th->control_stack_start;

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  2b29a7c2b236cfab1d4d06311e84414abba71b4c (commit)
      from  d8422b9967f465801891907396bcc5bfde0f3297 (commit)

- Log -----------------------------------------------------------------
commit 2b29a7c2b236cfab1d4d06311e84414abba71b4c
Author: David Lichteblau <david@...>
Date:   Fri Dec 21 21:29:23 2012 +0100

    Update NEWS
---
 NEWS |   22 ++++++++++++++++++++++
 1 files changed, 22 insertions(+), 0 deletions(-)

diff --git a/NEWS b/NEWS
index 13036cc..c274228 100644
--- a/NEWS
+++ b/NEWS
@@ -2,9 +2,31 @@
 changes relative to sbcl-1.1.2:
   * enhancement: warnings about bad locale settings, LANG, LC_CTYPE, etc.
     (lp#727625)
+  * enhancement: support for C-c to interrupt the foreground thread
+    on Windows.  (Thanks to Anton Kovalenko.)
+  * enhancement: STDCALL alien callbacks. (Thanks to Anton Kovalenko.)
+  * enhancement: Safepoint builds on POSIX platforms can now optionally be
+    built without pseudo-atomic sequences and their run-time overhead.
+  * enhancement: Threads created outside of Lisp can enter Lisp through
+    alien callbacks and appear as Lisp threads for the duration of that
+    function invocation.  On safepoint builds only.
+  * enhancement: Miscellaneous improvements to namestrings and underlying
+    calls to OS functions for file system access on Windows.  (Thanks to
+    Anton Kovalenko.)
+  * enhancement: The MSI installer support for Windows now uses Windows
+    Installer XML at least version 3.5 and includes various usability
+    improvements.  (Thanks to Dmitry Kalyanov and Anton Kovalenko.)
+  * enhancement: The sb-bsd-sockets contrib now supports non-blocking-mode
+    on Windows.  (Thanks to Anton Kovalenko.)
+  * enhancement: The Windows backend now supports the x86-64 platform.
+    (Thanks to Anton Kovalenko.)
   * bug fix: fasls are now once again directly executable (on platforms
     supporting shebang lines, with a suitably-installed sbcl).
   * bug fix: make.sh --help no longer runs clean.sh. (lp#937001)
+  * bug fix: Fix CAS access to slots of direct instances of structure classes
+    in the presence of subclasses sharing the same conc-name.
+  * bug fix: Logical pathname namestrings on Windows have been changed to
+    be lower-case, to minimize differences between POSIX and Windows.
 
 changes in sbcl-1.1.2 relative to sbcl-1.1.1:
   * notice: System requirements for SBCL on Microsoft Windows: Windows NT 5.1

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  d8422b9967f465801891907396bcc5bfde0f3297 (commit)
      from  935edfc8f060a4fda050a66fcb7e631a81c490c6 (commit)

- Log -----------------------------------------------------------------
commit d8422b9967f465801891907396bcc5bfde0f3297
Author: David Lichteblau <david@...>
Date:   Mon Dec 17 18:33:43 2012 +0100

    Preserve superclass structure accessors in infodb
    
    Do not overwrite inherited structure accessor entries in infodb when
    a sub-structure-class gets defined with same conc-name.
    
    Fixes CAS access to slots of direct superclass instances in this
    case (and in particular, non-futex safepoint builds).
---
 src/code/defstruct.lisp            |    2 +-
 tests/compare-and-swap.impure.lisp |    4 ++++
 2 files changed, 5 insertions(+), 1 deletions(-)

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index c3beef9..9ff1cb9 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1127,10 +1127,10 @@
       (let* ((accessor-name (dsd-accessor-name dsd))
              (dsd-type (dsd-type dsd)))
         (when accessor-name
-          (setf (info :function :structure-accessor accessor-name) dd)
           (let ((inherited (accessor-inherited-data accessor-name dd)))
             (cond
               ((not inherited)
+               (setf (info :function :structure-accessor accessor-name) dd)
                (multiple-value-bind (reader-designator writer-designator)
                    (slot-accessor-transforms dd dsd)
                  (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
index e1dc09b..b368f8c 100644
--- a/tests/compare-and-swap.impure.lisp
+++ b/tests/compare-and-swap.impure.lisp
@@ -120,6 +120,10 @@
 (defstruct box
   (word 0 :type sb-vm:word))
 
+;; Have the following tests check that CAS access to the superclass
+;; works in the presence of a subclass sharing the conc-name.
+(defstruct (subbox (:include box) (:conc-name "BOX-")))
+
 (defun inc-box (box n)
   (declare (fixnum n) (box box))
   (loop repeat n

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  935edfc8f060a4fda050a66fcb7e631a81c490c6 (commit)
      from  79721a8731b8582ad8df664c2c4e04bd3d6090c6 (commit)

- Log -----------------------------------------------------------------
commit 935edfc8f060a4fda050a66fcb7e631a81c490c6
Author: David Lichteblau <david@...>
Date:   Mon Dec 10 13:56:17 2012 +0100

    Set a console Ctrl handler for Windows
    
    Install a Lisp callback using SetConsoleCtrlHandler, allowing users
    to interrupt SBCL using C-c in the Windows console.
    
    We cannot currently control the size of the stack available to us in
    this handler, but since we are mainly only calling INTERRUPT-THREAD,
    even a small stack might be sufficient for our purposes.
    
    Thanks to Anton Kovalenko.
---
 src/code/target-signal.lisp |    9 ++++++
 src/code/warm-mswin.lisp    |   62 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 71 insertions(+), 0 deletions(-)

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 3fd22f3..d380760 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -214,6 +214,15 @@
   (declare (type system-area-pointer context))
   (/show "in Lisp-level SIGINT handler" (sap-int context))
   (flet ((interrupt-it ()
+           ;; This seems wrong to me on multi-threaded builds.  The
+           ;; closed-over signal context belongs to a SIGINT handler.
+           ;; But this function gets run through INTERRUPT-THREAD,
+           ;; i.e. in in a SIGPIPE handler, at a different point in time
+           ;; or even a different thread.  How do we know that the
+           ;; SIGINT's context structure from the other thread is still
+           ;; alive and meaningful?  Why do we care?  If we even need
+           ;; the context and PC, shouldn't they come from the SIGPIPE's
+           ;; context? --DFL
            (with-alien ((context (* os-context-t) context))
              (with-interrupts
                (let ((int (make-condition 'interactive-interrupt
diff --git a/src/code/warm-mswin.lisp b/src/code/warm-mswin.lisp
index eef4e56..5a973ff 100644
--- a/src/code/warm-mswin.lisp
+++ b/src/code/warm-mswin.lisp
@@ -104,3 +104,65 @@
                               (if got code -1))))
                     child))
               -2))))))
+
+(define-alien-routine ("SetConsoleCtrlHandler" set-console-ctrl-handler) int
+  (callback (function (:stdcall int) int))
+  (enable int))
+
+(defun windows-console-control-handler (event-code)
+  (case event-code
+    (0
+     (flet ((interrupt-it ()
+              (let* ((context
+                       (sb-di::nth-interrupt-context
+                        (1- sb-kernel:*free-interrupt-context-index*)))
+                     (pc (sb-vm:context-pc context)))
+                (with-interrupts
+                  (let ((int (make-condition
+                              'interactive-interrupt
+                              :context context
+                              :address (sb-sys:sap-int pc))))
+                    ;; First SIGNAL, so that handlers can run.
+                    (signal int)
+                    (%break 'sigint int))))))
+       (sb-thread:interrupt-thread (sb-thread::foreground-thread)
+                                   #'interrupt-it)
+       t))))
+
+(defvar *console-control-handler* #'windows-console-control-handler)
+(defvar *console-control-enabled* nil)
+(defvar *console-control-spec* nil)
+
+(sb-alien::define-alien-callback *alien-console-control-handler* (:stdcall int)
+    ((event-code int))
+  (if (ignore-errors (funcall *console-control-handler* event-code)) 1 0))
+
+(defun console-control-handler ()
+  "Get or set windows console control handler.
+
+Boolean value: use default handler (NIL) or ignore event (T).  Symbol
+or function: designator for a function that receives an event code and
+returns generalized boolean (false to fall back to other handlers,
+true to stop searching)." *console-control-spec*)
+
+(defun (setf console-control-handler) (new-handler)
+  (etypecase new-handler
+    (boolean
+     (aver (plusp (set-console-ctrl-handler
+                   (sap-alien (int-sap 0)
+                              (function (:stdcall int) int))
+                   (if new-handler 1 0))))
+     (setf *console-control-enabled* nil))
+    ((or symbol function)
+     (setf *console-control-handler* new-handler)
+     (aver (plusp (set-console-ctrl-handler *alien-console-control-handler* 1)))))
+  (setf *console-control-spec* new-handler))
+
+(defun initialize-console-control-handler (&optional reset-to-default-p)
+  (setf (console-control-handler)
+        (if reset-to-default-p
+            'windows-console-control-handler
+            (console-control-handler))))
+
+(initialize-console-control-handler t)
+(pushnew 'initialize-console-control-handler sb-ext:*init-hooks*)

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  79721a8731b8582ad8df664c2c4e04bd3d6090c6 (commit)
      from  37d3828773e2f847bb1ed7522b0af4fb8e736fc8 (commit)

- Log -----------------------------------------------------------------
commit 79721a8731b8582ad8df664c2c4e04bd3d6090c6
Author: David Lichteblau <david@...>
Date:   Fri Nov 9 14:54:19 2012 +0100

    Add STDCALL alien convention support for Windows
    
    Thanks to Anton Kovalenko.
---
 src/code/host-alieneval.lisp   |   55 ++++++++++++++++++++++++++++++++++-----
 src/code/target-alieneval.lisp |   41 +++++++++++++++++++++--------
 src/compiler/x86/c-call.lisp   |    5 ++-
 3 files changed, 81 insertions(+), 20 deletions(-)

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index eb883db..8e61909 100644
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -1137,27 +1137,68 @@
 
 ;;;; the FUNCTION and VALUES alien types
 
+;;; Calling-convention spec, typically one of predefined keywords.
+;;; Add or remove as needed for target platform.  It makes sense to
+;;; support :cdecl everywhere.
+;;;
+;;; Null convention is supposed to be platform-specific most-universal
+;;; callout convention. For x86, SBCL calls foreign functions in a way
+;;; allowing them to be either stdcall or cdecl; null convention is
+;;; appropriate here, as it is for specifying callbacks that could be
+;;; accepted by foreign code both in cdecl and stdcall form.
+(def!type calling-convention () `(or null (member :stdcall :cdecl)))
+
+;;; Convention could be a values type class, stored at result-type.
+;;; However, it seems appropriate only for epilogue-related
+;;; conventions, those not influencing incoming arg passing.
+;;;
+;;; As of x86's :stdcall and :cdecl, supported by now, both are
+;;; epilogue-related, but future extensions (like :fastcall and
+;;; miscellaneous non-x86 stuff) might affect incoming argument
+;;; translation as well.
+
 (define-alien-type-class (fun :include mem-block)
   (result-type (missing-arg) :type alien-type)
   (arg-types (missing-arg) :type list)
-  (stub nil :type (or null function)))
+  (stub nil :type (or null function))
+  (convention nil :type calling-convention))
+
+;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
+;;; convention specification for function types is unobvious.
+;;;
+;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
+;;; starting with a convention keyword; its second item is a real
+;;; result-type in this case. If convention is ever to become a part
+;;; of result-type, such a syntax can be retained.
 
 (define-alien-type-translator function (result-type &rest arg-types
                                                     &environment env)
-  (make-alien-fun-type
-   :result-type (let ((*values-type-okay* t))
-                  (parse-alien-type result-type env))
-   :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
-                      arg-types)))
+  (multiple-value-bind (bare-result-type calling-convention)
+      (typecase result-type
+        ((cons calling-convention *)
+           (values (second result-type) (first result-type)))
+        (t result-type))
+    (make-alien-fun-type
+     :convention calling-convention
+     :result-type (let ((*values-type-okay* t))
+                    (parse-alien-type bare-result-type env))
+     :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
+                        arg-types))))
 
 (define-alien-type-method (fun :unparse) (type)
-  `(function ,(%unparse-alien-type (alien-fun-type-result-type type))
+  `(function ,(let ((result-type
+                     (%unparse-alien-type (alien-fun-type-result-type type)))
+                    (convention (alien-fun-type-convention type)))
+                (if convention (list convention result-type)
+                    result-type))
              ,@(mapcar #'%unparse-alien-type
                        (alien-fun-type-arg-types type))))
 
 (define-alien-type-method (fun :type=) (type1 type2)
   (and (alien-type-= (alien-fun-type-result-type type1)
                      (alien-fun-type-result-type type2))
+       (eq (alien-fun-type-convention type1)
+           (alien-fun-type-convention type2))
        (= (length (alien-fun-type-arg-types type1))
           (length (alien-fun-type-arg-types type2)))
        (every #'alien-type-=
diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 7e9b25e..e746b72 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -867,8 +867,10 @@ we don't create new wrappers if one for the same specifier already exists.")
   "Lisp trampoline store: assembler wrappers contain indexes to this, and
 ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
 
-(defun %alien-callback-sap (specifier result-type argument-types function wrapper)
-  (let ((key (cons specifier function)))
+(defun %alien-callback-sap (specifier result-type argument-types function wrapper
+                            &optional call-type)
+  (declare #!-x86 (ignore call-type))
+  (let ((key (list specifier function)))
     (or (gethash key *alien-callbacks*)
         (setf (gethash key *alien-callbacks*)
               (let* ((index (fill-pointer *alien-callback-trampolines*))
@@ -879,8 +881,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
                      ;; per-function tramp would need assembler at
                      ;; runtime. Possibly we could even pregenerate
                      ;; the code and just patch the index in later.
-                     (assembler-wrapper (alien-callback-assembler-wrapper
-                                         index result-type argument-types)))
+                     (assembler-wrapper
+                      (alien-callback-assembler-wrapper
+                       index result-type argument-types
+                       #!+x86
+                       (if (eq call-type :stdcall)
+                           (ceiling
+                            (apply #'+
+                                   (mapcar 'alien-type-word-aligned-bits
+                                           argument-types))
+                            8)
+                           0))))
                 (vector-push-extend
                  (alien-callback-lisp-trampoline wrapper function)
                  *alien-callback-trampolines*)
@@ -959,11 +970,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
   (destructuring-bind (function result-type &rest argument-types)
       specifier
     (aver (eq 'function function))
-    (values (let ((*values-type-okay* t))
-              (parse-alien-type result-type env))
-            (mapcar (lambda (spec)
-                      (parse-alien-type spec env))
-                    argument-types))))
+    (multiple-value-bind (bare-result-type calling-convention)
+        (typecase result-type
+          ((cons calling-convention *)
+             (values (second result-type) (first result-type)))
+          (t result-type))
+      (values (let ((*values-type-okay* t))
+                (parse-alien-type bare-result-type env))
+              (mapcar (lambda (spec)
+                        (parse-alien-type spec env))
+                      argument-types)
+              calling-convention))))
 
 (defun alien-void-type-p (type)
   (and (alien-values-type-p type) (not (alien-values-type-values type))))
@@ -999,7 +1016,8 @@ SPECIFIER and FUNCTION already exists, it is returned instead of consing a new
 one."
   ;; Pull out as much work as is convenient to macro-expansion time, specifically
   ;; everything that can be done given just the SPECIFIER and ENV.
-  (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env)
+  (multiple-value-bind (result-type argument-types call-type)
+      (parse-alien-ftype specifier env)
     `(%sap-alien
       (%alien-callback-sap ',specifier ',result-type ',argument-types
                            ,function
@@ -1007,7 +1025,8 @@ one."
                                (setf (gethash ',specifier *alien-callback-wrappers*)
                                      (compile nil
                                               ',(alien-callback-lisp-wrapper-lambda
-                                                 specifier result-type argument-types env)))))
+                                                 specifier result-type argument-types env))))
+                           ,call-type)
       ',(parse-alien-type specifier env))))
 
 (defun alien-callback-p (alien)
diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 8cd0e07..4d57b8e 100644
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -403,7 +403,8 @@
   `(deref (sap-alien (sap+ ,sp ,offset) (* ,type))))
 
 #-sb-xc-host
-(defun alien-callback-assembler-wrapper (index return-type arg-types)
+(defun alien-callback-assembler-wrapper
+    (index return-type arg-types &optional (stack-offset 0))
   "Cons up a piece of code which calls call-callback with INDEX and a
 pointer to the arguments."
   (declare (ignore arg-types))
@@ -461,7 +462,7 @@ pointer to the arguments."
                  (error "unrecognized alien type: ~A" return-type)))
               (inst mov esp ebp)                   ; discard frame
               (inst pop ebp)                       ; restore frame pointer
-              (inst ret))
+              (inst ret stack-offset))
     (finalize-segment segment)
     ;; Now that the segment is done, convert it to a static
     ;; vector we can point foreign code to.

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  37d3828773e2f847bb1ed7522b0af4fb8e736fc8 (commit)
      from  daa6f0ce672d8dc60176ff885da18e44ee0355c6 (commit)

- Log -----------------------------------------------------------------
commit 37d3828773e2f847bb1ed7522b0af4fb8e736fc8
Author: David Lichteblau <david@...>
Date:   Wed Dec 5 19:08:23 2012 +0100

    Support building without PSEUDO-ATOMIC on POSIX safepoints
    
      - Mark Lisp signal handlers with a flag `synchronous' to indicate
        whether we can (and must) handle them immediately.  Conversely,
        we understand this flag to imply a guarantee that the signal
        does not occur during allocation.
    
      - Any signal with a Lisp handler that is not synchronous is
        implemented in the runtime using a trampoline, which (instead of
        invoking Lisp code directly) first spawns a new pthread, which
        only then calls back into Lisp to invoke the handler function
        (with a fake signal context).
    
      - Used in particular for SIGINT.
    
      - For SIGPROF, introduce a second per-thread allocation region,
        which gets swapped with the usual region around the call into
        SIGPROF-HANDLER.  This handler is a special case, because it is
        careful not to trigger GC nor non-local unwinds, and we can
        safely return to the original region afterwards.
    
      - Add a new subclass SIGNAL-HANDLER-THREAD for this purpose,
        making it easy to identify these threads (e.g. in the test
        driver).
    
      - Run sprof tests while building the contrib.  Add a test stressing
        time profiling of allocation sequences.
    
    Enable using :SB-SAFEPOINT-STRICTLY on features.
    
    Quite usable already on x86 and x86-64; PPC still has more prominent
    issues, e.g. in threads.impure.lisp.
---
 contrib/sb-sprof/Makefile        |    2 +-
 contrib/sb-sprof/sb-sprof.lisp   |   21 ++++++++-
 contrib/sb-sprof/test.lisp       |   13 +++++
 make-config.sh                   |    1 +
 package-data-list.lisp-expr      |    2 +
 src/code/target-signal.lisp      |   49 +++++++++++++++++---
 src/code/thread.lisp             |    8 +++
 src/compiler/generic/objdef.lisp |    2 +
 src/compiler/generic/parms.lisp  |    4 +-
 src/compiler/ppc/macros.lisp     |    3 +
 src/compiler/x86-64/macros.lisp  |    4 +-
 src/compiler/x86/macros.lisp     |    4 +-
 src/runtime/gencgc.c             |   12 +++--
 src/runtime/interrupt.c          |   92 +++++++++++++++++++++++++++++++++++++-
 src/runtime/interrupt.h          |    3 +-
 src/runtime/runtime.c            |    2 +-
 src/runtime/safepoint.c          |   20 ++++++++
 src/runtime/thread.c             |    9 ++++
 src/runtime/thread.h             |    5 ++
 tests/signals.impure.lisp        |   12 ++++-
 tests/test-util.lisp             |    4 ++
 21 files changed, 247 insertions(+), 25 deletions(-)

diff --git a/contrib/sb-sprof/Makefile b/contrib/sb-sprof/Makefile
index 463ae52..7373c72 100644
--- a/contrib/sb-sprof/Makefile
+++ b/contrib/sb-sprof/Makefile
@@ -2,4 +2,4 @@ MODULE=sb-sprof
 include ../vanilla-module.mk
 
 test::
-	        true
+	$(SBCL) --eval '(load (format nil "SYS:CONTRIB;~:@(~A~);TEST.LISP" "$(MODULE)"))' </dev/null
diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp
index 775924a..0d81649 100644
--- a/contrib/sb-sprof/sb-sprof.lisp
+++ b/contrib/sb-sprof/sb-sprof.lisp
@@ -792,7 +792,9 @@ The following keyword args are recognized:
                                     :mode mode))
       (enable-call-counting)
       (setf *profiled-threads* threads)
-      (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler)
+      (sb-sys:enable-interrupt sb-unix:sigprof
+                               #'sigprof-handler
+                               :synchronous t)
       (ecase mode
         (:alloc
          (let ((alloc-signal (1- alloc-interval)))
@@ -1405,6 +1407,23 @@ functions during statistical profiling."
   (with-profiling (:reset t :max-samples 1000 :report :graph)
     (test-0 7)))
 
+(defun consalot ()
+  (let ((junk '()))
+    (loop repeat 10000 do
+         (push (make-array 10) junk))
+    junk))
+
+(defun consing-test ()
+  ;; 0.0001 chosen so that it breaks rather reliably when sprof does not
+  ;; respect pseudo atomic.
+  (with-profiling (:reset t :sample-interval 0.0001 :report :graph :loop nil)
+    (let ((target (+ (get-universal-time) 15)))
+      (princ #\.)
+      (force-output)
+      (loop
+         while (< (get-universal-time) target)
+         do (consalot)))))
+
 
 ;;; provision
 (provide 'sb-sprof)
diff --git a/contrib/sb-sprof/test.lisp b/contrib/sb-sprof/test.lisp
new file mode 100644
index 0000000..4be5763
--- /dev/null
+++ b/contrib/sb-sprof/test.lisp
@@ -0,0 +1,13 @@
+(in-package :cl-user)
+(require :sb-sprof)
+
+#-win32                                ;not yet
+(sb-sprof::test)
+#-win32                                ;not yet
+(sb-sprof::consing-test)
+
+;; For debugging purposes, print output for visual inspection to see if
+;; the allocation sequence gets hit in the right places (i.e. not at all
+;; in traditional builds, and everywhere if SB-SAFEPOINT-STRICTLY is
+;; enabled.)
+(disassemble #'sb-sprof::consalot)
diff --git a/make-config.sh b/make-config.sh
index 1a0a547..6b720e0 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -544,6 +544,7 @@ case "$sbcl_os" in
         # roughly-equivalent magic nevertheless:)
         printf ' :sb-dynamic-core :os-provides-dlopen' >> $ltf
         printf ' :sb-thread :sb-safepoint :sb-thruption :sb-wtimer' >> $ltf
+        printf ' :sb-safepoint-strictly' >> $ltf
         #
         link_or_copy Config.$sbcl_arch-win32 Config
         link_or_copy $sbcl_arch-win32-os.h target-arch-os.h
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 03ab6ee..691a040 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2023,6 +2023,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "THREAD-NAME"
                "THREAD-YIELD"
                "FOREIGN-THREAD"
+               #!+(and sb-safepoint-strictly (not win32))
+               "SIGNAL-HANDLING-THREAD"
                ;; Memory barrier
                "BARRIER"
                ;; Mutexes
diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 9fab9d1..3fd22f3 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -117,11 +117,25 @@
 (sb!alien:define-alien-routine ("install_handler" install-handler)
                                sb!alien:unsigned-long
   (signal sb!alien:int)
-  (handler sb!alien:unsigned-long))
+  (handler sb!alien:unsigned-long)
+  (synchronous boolean))
 
 ;;;; interface to enabling and disabling signal handlers
 
-(defun enable-interrupt (signal handler)
+;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic,
+;;; we have no way of knowing whether interrupted code was in an
+;;; allocation sequence, and cannot delay signals until after
+;;; allocation.  Any signal that can occur asynchronously must be
+;;; considered unsafe for immediate execution, and the invocation of its
+;;; lisp handler will get delayed into a newly spawned signal handler
+;;; thread.  However, there are signals which we must handle
+;;; immediately, because they occur synchonously (hence the boolean flag
+;;; SYNCHRONOUS to this function), luckily implying that the signal
+;;; happens only in specific places (illegal instructions, floating
+;;; point instructions, certain system calls), hopefully ruling out the
+;;; possibility that we would trigger it during allocation.
+
+(defun enable-interrupt (signal handler &key synchronous)
   (declare (type (or function fixnum (member :default :ignore)) handler))
   (/show0 "enable-interrupt")
   (flet ((run-handler (&rest args)
@@ -135,7 +149,8 @@
                                        (:ignore sig-ign)
                                        (t
                                         (sb!kernel:get-lisp-obj-address
-                                         #'run-handler))))))
+                                         #'run-handler)))
+                                     synchronous)))
         (cond ((= result sig-dfl) :default)
               ((= result sig-ign) :ignore)
               (t (the (or function fixnum)
@@ -147,6 +162,26 @@
 (defun ignore-interrupt (signal)
   (enable-interrupt signal :ignore))
 
+;;;; Support for signal handlers which aren't.
+;;;;
+;;;; On safepoint builds, user-defined Lisp signal handlers do not run
+;;;; in the handler for their signal, because we have no pseudo atomic
+;;;; mechanism to prevent handlers from hitting during allocation.
+;;;; Rather, the signal spawns off a fresh native thread, which calls
+;;;; into lisp with a fake context through this callback:
+
+#!+(and sb-safepoint-strictly (not win32))
+(defun signal-handler-callback (run-handler signal args)
+  (sb!thread::initial-thread-function-trampoline
+   (sb!thread::make-signal-handling-thread :name "signal handler"
+                                           :signal-number signal)
+   nil (lambda ()
+         (let* ((info (sb!sys:sap-ref-sap args 0))
+                (context (sb!sys:sap-ref-sap args sb!vm:n-word-bytes)))
+           (funcall run-handler signal info context)))
+   nil nil nil nil))
+
+
 ;;;; default LISP signal handlers
 ;;;;
 ;;;; Most of these just call ERROR to report the presence of the signal.
@@ -237,13 +272,13 @@
   "Enable all the default signals that Lisp knows how to deal with."
   (enable-interrupt sigint #'sigint-handler)
   (enable-interrupt sigterm #'sigterm-handler)
-  (enable-interrupt sigill #'sigill-handler)
+  (enable-interrupt sigill #'sigill-handler :synchronous t)
   #!-linux
   (enable-interrupt sigemt #'sigemt-handler)
-  (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
-  (enable-interrupt sigbus #'sigbus-handler)
+  (enable-interrupt sigfpe #'sb!vm:sigfpe-handler :synchronous t)
+  (enable-interrupt sigbus #'sigbus-handler :synchronous t)
   #!-linux
-  (enable-interrupt sigsys #'sigsys-handler)
+  (enable-interrupt sigsys #'sigsys-handler :synchronous t)
   #!-sb-wtimer
   (enable-interrupt sigalrm #'sigalrm-handler)
   #!-sb-thruption
diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 2cfd567..3d1ecd4 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -42,6 +42,14 @@ in future versions."
   "Type of native threads which are attached to the runtime as Lisp threads
 temporarily.")
 
+#!+(and sb-safepoint-strictly (not win32))
+(def!struct (signal-handling-thread
+             (:include foreign-thread)
+             (:conc-name "THREAD-"))
+  #!+sb-doc
+  "Asynchronous signal handling thread."
+  (signal-number nil :type integer))
+
 (def!struct mutex
   #!+sb-doc
   "Mutex type."
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index fda2758..262f472 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -434,6 +434,8 @@
   #!+sb-safepoint (csp-around-foreign-call :c-type "lispobj *")
   #!+sb-safepoint (pc-around-foreign-call :c-type "lispobj *")
   #!+win32 (synchronous-io-handle-and-flag :c-type "HANDLE" :length 1)
+  #!+(and sb-safepoint-strictly (not win32))
+  (sprof-alloc-region :c-type "struct alloc_region" :length 5)
   ;; KLUDGE: On alpha, until STEPPING we have been lucky and the 32
   ;; bit slots came in pairs. However the C compiler will align
   ;; interrupt_contexts on a double word boundary. This logic should
diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp
index ca556c2..4661321 100644
--- a/src/compiler/generic/parms.lisp
+++ b/src/compiler/generic/parms.lisp
@@ -124,7 +124,9 @@
     fdefinition-object
     #!+win32 sb!kernel::handle-win32-exception
     #!+sb-thruption sb!thread::run-interruption
-    #!+sb-safepoint sb!thread::enter-foreign-callback))
+    #!+sb-safepoint sb!thread::enter-foreign-callback
+    #!+(and sb-safepoint-strictly (not win32))
+    sb!unix::signal-handler-callback))
 
 (defparameter *common-static-symbols*
   '(t
diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index 2fdfb7e..262cc10 100644
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -336,6 +336,9 @@
 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
 (defmacro pseudo-atomic ((flag-tn) &body forms)
+  #!+sb-safepoint-strictly
+  `(progn ,flag-tn ,@forms (emit-safepoint))
+  #!-sb-safepoint-strictly
   `(progn
      (without-scheduling ()
        ;; Extra debugging stuff:
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 11a06fc..a397573 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -303,9 +303,9 @@
 
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
-  #!+win32
+  #!+sb-safepoint-strictly
   `(progn ,@forms (emit-safepoint))
-  #!-win32
+  #!-sb-safepoint-strictly
   (with-unique-names (label)
     `(let ((,label (gen-label)))
        (inst mov (make-ea :qword
diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index d7b6bc2..4050640 100644
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -408,9 +408,9 @@
 
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
-  #!+win32
+  #!+sb-safepoint-strictly
   `(progn ,@forms (emit-safepoint))
-  #!-win32
+  #!-sb-safepoint-strictly
   (with-unique-names (label)
     `(let ((,label (gen-label)))
        (inst mov (make-ea :dword :disp (* 4 thread-pseudo-atomic-bits-slot))
diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
index 5829b5a..f4ffd2f 100644
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -4306,9 +4306,7 @@ general_alloc(sword_t nbytes, int page_type_flag)
 lispobj AMD64_SYSV_ABI *
 alloc(long nbytes)
 {
-#ifdef LISP_FEATURE_WIN32
-    /* WIN32 is currently the only platform where inline allocation is
-     * not pseudo atomic. */
+#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY
     struct thread *self = arch_os_get_current_thread();
     int was_pseudo_atomic = get_pseudo_atomic_atomic(self);
     if (!was_pseudo_atomic)
@@ -4319,7 +4317,7 @@ alloc(long nbytes)
 
     lispobj *result = general_alloc(nbytes, BOXED_PAGE_FLAG);
 
-#ifdef LISP_FEATURE_WIN32
+#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY
     if (!was_pseudo_atomic)
         clear_pseudo_atomic_atomic(self);
 #endif
@@ -4434,8 +4432,12 @@ void gc_alloc_update_all_page_tables(void)
 {
     /* Flush the alloc regions updating the tables. */
     struct thread *th;
-    for_each_thread(th)
+    for_each_thread(th) {
         gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+        gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
+#endif
+    }
     gc_alloc_update_page_tables(UNBOXED_PAGE_FLAG, &unboxed_region);
     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &boxed_region);
 }
diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c
index d23dbd7..882e2bb 100644
--- a/src/runtime/interrupt.c
+++ b/src/runtime/interrupt.c
@@ -1779,6 +1779,89 @@ see_if_sigaction_nodefer_works(void)
 #undef SA_NODEFER_TEST_BLOCK_SIGNAL
 #undef SA_NODEFER_TEST_KILL_SIGNAL
 
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+
+static void *
+signal_thread_trampoline(void *pthread_arg)
+{
+    int signo = (int) pthread_arg;
+    os_context_t fake_context;
+    siginfo_t fake_info;
+#ifdef LISP_FEATURE_PPC
+    mcontext_t uc_regs;
+#endif
+
+    memset(&fake_info, 0, sizeof(fake_info));
+    memset(&fake_context, 0, sizeof(fake_context));
+#ifdef LISP_FEATURE_PPC
+    memset(&uc_regs, 0, sizeof(uc_regs));
+    fake_context.uc_mcontext.uc_regs = &uc_regs;
+#endif
+
+    *os_context_pc_addr(&fake_context) = &signal_thread_trampoline;
+#ifdef ARCH_HAS_STACK_POINTER /* aka x86(-64) */
+    *os_context_sp_addr(&fake_context) = __builtin_frame_address(0);
+#endif
+
+    signal_handler_callback(interrupt_handlers[signo].lisp,
+                            signo, &fake_info, &fake_context);
+    return 0;
+}
+
+static void
+sigprof_handler_trampoline(int signal, siginfo_t *info, void *void_context)
+{
+    SAVE_ERRNO(signal,context,void_context);
+    struct thread *self = arch_os_get_current_thread();
+
+    /* alloc() is not re-entrant and still uses pseudo atomic (even though
+     * inline allocation does not).  In this case, give up. */
+    if (get_pseudo_atomic_atomic(self))
+        goto cleanup;
+
+    struct alloc_region tmp = self->alloc_region;
+    self->alloc_region = self->sprof_alloc_region;
+    self->sprof_alloc_region = tmp;
+
+    interrupt_handle_now_handler(signal, info, void_context);
+
+    /* And we're back.  We know that the SIGPROF handler never unwinds
+     * non-locally, and can simply swap things back: */
+
+    tmp = self->alloc_region;
+    self->alloc_region = self->sprof_alloc_region;
+    self->sprof_alloc_region = tmp;
+
+cleanup:
+    ; /* Dear C compiler, it's OK to have a label here. */
+    RESTORE_ERRNO;
+}
+
+static void
+spawn_signal_thread_handler(int signal, siginfo_t *info, void *void_context)
+{
+    SAVE_ERRNO(signal,context,void_context);
+
+    pthread_attr_t attr;
+    pthread_t th;
+
+    if (pthread_attr_init(&attr))
+        goto lost;
+    if (pthread_attr_setstacksize(&attr, thread_control_stack_size))
+        goto lost;
+    if (pthread_create(&th, &attr, &signal_thread_trampoline, (void*) signal))
+        goto lost;
+    if (pthread_attr_destroy(&attr))
+        goto lost;
+
+    RESTORE_ERRNO;
+    return;
+
+lost:
+    lose("spawn_signal_thread_handler");
+}
+#endif
+
 static void
 unblock_me_trampoline(int signal, siginfo_t *info, void *void_context)
 {
@@ -1863,7 +1946,8 @@ undoably_install_low_level_interrupt_handler (int signal,
 
 /* This is called from Lisp. */
 uword_t
-install_handler(int signal, void handler(int, siginfo_t*, os_context_t*))
+install_handler(int signal, void handler(int, siginfo_t*, os_context_t*),
+                int synchronous)
 {
 #ifndef LISP_FEATURE_WIN32
     struct sigaction sa;
@@ -1880,6 +1964,12 @@ install_handler(int signal, void handler(int, siginfo_t*, os_context_t*))
         if (ARE_SAME_HANDLER(handler, SIG_DFL) ||
             ARE_SAME_HANDLER(handler, SIG_IGN))
             sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))handler;
+#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY
+        else if (signal == SIGPROF)
+            sa.sa_sigaction = sigprof_handler_trampoline;
+        else if (!synchronous)
+            sa.sa_sigaction = spawn_signal_thread_handler;
+#endif
         else if (sigismember(&deferrable_sigset, signal))
             sa.sa_sigaction = maybe_now_maybe_later;
         else if (!sigaction_nodefer_works &&
diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h
index a27eb08..07b4a2d 100644
--- a/src/runtime/interrupt.h
+++ b/src/runtime/interrupt.h
@@ -158,7 +158,8 @@ extern void undoably_install_low_level_interrupt_handler (
                         int signal,
                         interrupt_handler_t handler);
 extern uword_t install_handler(int signal,
-                                     interrupt_handler_t handler);
+                               interrupt_handler_t handler,
+                               int synchronous);
 
 extern union interrupt_handler interrupt_handlers[NSIG];
 
diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c
index 3bc18ee..49c007b 100644
--- a/src/runtime/runtime.c
+++ b/src/runtime/runtime.c
@@ -95,7 +95,7 @@ void
 sigint_init(void)
 {
     SHOW("entering sigint_init()");
-    install_handler(SIGINT, sigint_handler);
+    install_handler(SIGINT, sigint_handler, 1);
     SHOW("leaving sigint_init()");
 }
 
diff --git a/src/runtime/safepoint.c b/src/runtime/safepoint.c
index a9e578c..45af50e 100644
--- a/src/runtime/safepoint.c
+++ b/src/runtime/safepoint.c
@@ -966,6 +966,26 @@ handle_safepoint_violation(os_context_t *ctx, os_vm_address_t fault_address)
 }
 #endif /* LISP_FEATURE_WIN32 */
 
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+void
+signal_handler_callback(lispobj run_handler, int signo, void *info, void *ctx)
+{
+    init_thread_data scribble;
+    void *args[2];
+    args[0] = info;
+    args[1] = ctx;
+
+    attach_os_thread(&scribble);
+
+    odxprint(misc, "callback from signal handler thread for: %d\n", signo);
+    funcall3(StaticSymbolFunction(SIGNAL_HANDLER_CALLBACK),
+             run_handler, make_fixnum(signo), alloc_sap(args));
+
+    detach_os_thread(&scribble);
+    return;
+}
+#endif
+
 void
 callback_wrapper_trampoline(
 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 4d20d0f..46f8f7d 100644
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -401,6 +401,9 @@ undo_init_new_thread(struct thread *th, init_thread_data *scribble)
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     block_blockable_signals(0, 0);
     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+    gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
+#endif
     pop_gcing_safety(&scribble->safety);
     lock_ret = pthread_mutex_lock(&all_threads_lock);
     gc_assert(lock_ret == 0);
@@ -418,6 +421,9 @@ undo_init_new_thread(struct thread *th, init_thread_data *scribble)
     gc_assert(lock_ret == 0);
 
     gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+    gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
+#endif
     unlink_thread(th);
     pthread_mutex_unlock(&all_threads_lock);
     gc_assert(lock_ret == 0);
@@ -700,6 +706,9 @@ create_thread_struct(lispobj initial_function) {
 #endif
 #ifdef LISP_FEATURE_GENCGC
     gc_set_region_empty(&th->alloc_region);
+# if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+    gc_set_region_empty(&th->sprof_alloc_region);
+# endif
 #endif
 #ifdef LISP_FEATURE_SB_THREAD
     /* This parallels the same logic in globals.c for the
diff --git a/src/runtime/thread.h b/src/runtime/thread.h
index 8bde9ba..1a004c0 100644
--- a/src/runtime/thread.h
+++ b/src/runtime/thread.h
@@ -422,6 +422,11 @@ int check_pending_thruptions(os_context_t *ctx);
 void attach_os_thread(init_thread_data *);
 void detach_os_thread(init_thread_data *);
 
+# if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+
+void signal_handler_callback(lispobj, int, void *, void *);
+# endif
+
 #endif
 
 extern void create_initial_thread(lispobj);
diff --git a/tests/signals.impure.lisp b/tests/signals.impure.lisp
index 716580c..c4f347e 100644
--- a/tests/signals.impure.lisp
+++ b/tests/signals.impure.lisp
@@ -70,9 +70,15 @@
                   :skipped-on :win32)
   (assert (eq :condition
               (handler-case
-                  (sb-thread::kill-safely
-                   (sb-thread::thread-os-thread sb-thread::*current-thread*)
-                   sb-unix:sigint)
+                  (progn
+                    (sb-thread::kill-safely
+                     (sb-thread::thread-os-thread sb-thread::*current-thread*)
+                     sb-unix:sigint)
+                    #+sb-safepoint-strictly
+                    ;; In this case, the signals handler gets invoked
+                    ;; indirectly through an INTERRUPT-THREAD.  Give it
+                    ;; enough time to hit.
+                    (sleep 1))
                 (sb-sys:interactive-interrupt ()
                   :condition)))))
 
diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index 1d44174..20b2c54 100644
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -69,6 +69,10 @@
                     (setf ,threads (union (union *threads-to-kill*
                                                  *threads-to-join*)
                                           ,threads))
+                    #+(and sb-safepoint-strictly (not win32))
+                    (dolist (thread (sb-thread:list-all-threads))
+                      (when (typep thread 'sb-thread:signal-handling-thread)
+                        (ignore-errors (sb-thread:join-thread thread))))
                     (dolist (thread (sb-thread:list-all-threads))
                       (unless (or (not (sb-thread:thread-alive-p thread))
                                   (eql thread sb-thread:*current-thread*)

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  daa6f0ce672d8dc60176ff885da18e44ee0355c6 (commit)
      from  d80e517dc02941c51b8732a9a449eaac0c388c94 (commit)

- Log -----------------------------------------------------------------
commit daa6f0ce672d8dc60176ff885da18e44ee0355c6
Author: David Lichteblau <david@...>
Date:   Wed Dec 12 14:30:52 2012 +0100

    Foreign callbacks
    
    Allow alien callbacks to be invoked in pthreads created outside of
    the Lisp runtime:
    
    Add new runtime functions attach_os_thread, detach_os_thread
    allowing such threads to acquire a `struct thread' temporarily,
    turning them into Lisp threads.
    
    In a main deviation from the Windows branch (which has a similar
    feature), this mechanism does not involve user-land thread (fiber)
    mechanisms to switch between stacks.  Instead, Lisp code merely runs
    on the existing pthread's stack.
    
    Currently a safepoint-only feature, because only safepoint-based
    builds already go through a convenient trampoline function for
    callbacks, but a backport of this feature to non-safepoint builds
    might be straightforward.
---
 package-data-list.lisp-expr     |    1 +
 src/code/target-thread.lisp     |   19 +++++++--
 src/code/thread.lisp            |    7 +++
 src/compiler/generic/parms.lisp |    3 +-
 src/runtime/safepoint.c         |   12 +++++-
 src/runtime/thread.c            |   80 +++++++++++++++++++++++++++++++++++++--
 src/runtime/thread.h            |    5 ++-
 7 files changed, 114 insertions(+), 13 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 8e96d24..03ab6ee 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2022,6 +2022,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "THREAD-EMPHEMERAL-P"
                "THREAD-NAME"
                "THREAD-YIELD"
+               "FOREIGN-THREAD"
                ;; Memory barrier
                "BARRIER"
                ;; Mutexes
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c668eea..80e3fee 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1351,7 +1351,7 @@ have the foreground next."
 
 #!+sb-thread
 (defun initial-thread-function-trampoline
-    (thread setup-sem real-function arguments)
+    (thread setup-sem real-function arguments arg1 arg2 arg3)
   ;; In time we'll move some of the binding presently done in C here
   ;; too.
   ;;
@@ -1388,7 +1388,7 @@ have the foreground next."
       (with-session-lock (*session*)
         (push thread (session-threads *session*)))
       (setf (thread-%alive-p thread) t)
-      (signal-semaphore setup-sem)
+      (when setup-sem (signal-semaphore setup-sem))
       ;; Using handling-end-of-the-world would be a bit tricky
       ;; due to other catches and interrupts, so we essentially
       ;; re-implement it here. Once and only once more.
@@ -1400,14 +1400,17 @@ have the foreground next."
               (without-interrupts
                   (unwind-protect
                        (with-local-interrupts
-                           (sb!unix::unblock-deferrable-signals)
+                         (setf *gc-inhibit* nil) ;for foreign callbacks
+                         (sb!unix::unblock-deferrable-signals)
                          (setf (thread-result thread)
                                (prog1
                                    (cons t
                                          (multiple-value-list
                                           (unwind-protect
                                                (catch '%return-from-thread
-                                                 (apply real-function arguments))
+                                                 (if (listp arguments)
+                                                     (apply real-function arguments)
+                                                     (funcall real-function arg1 arg2 arg3)))
                                             (when *exit-in-process*
                                               (sb!impl::call-exit-hooks)))))
                                  #!+sb-safepoint
@@ -1457,7 +1460,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
                  ;; As it is, this lambda must not cons until we are ready
                  ;; to run GC. Be very careful.
                  (initial-thread-function-trampoline
-                  thread setup-sem real-function arguments))))
+                  thread setup-sem real-function arguments nil nil nil))))
          ;; If the starting thread is stopped for gc before it signals the
          ;; semaphore then we'd be stuck.
          (assert (not *gc-inhibit*))
@@ -1514,6 +1517,12 @@ subject to change."
   "Deprecated. Same as TERMINATE-THREAD."
   (terminate-thread thread))
 
+#!+sb-safepoint
+(defun enter-foreign-callback (arg1 arg2 arg3)
+  (initial-thread-function-trampoline
+   (make-foreign-thread :name "foreign callback")
+   nil #'sb!alien::enter-alien-callback t arg1 arg2 arg3))
+
 (defmacro with-interruptions-lock ((thread) &body body)
   `(with-system-mutex ((thread-interruptions-lock ,thread))
      ,@body))
diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index e45fa64..2cfd567 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -35,6 +35,13 @@ in future versions."
    :type mutex)
   waiting-for)
 
+(def!struct (foreign-thread
+             (:include thread)
+             (:conc-name "THREAD-"))
+  #!+sb-doc
+  "Type of native threads which are attached to the runtime as Lisp threads
+temporarily.")
+
 (def!struct mutex
   #!+sb-doc
   "Mutex type."
diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp
index abe0fba..ca556c2 100644
--- a/src/compiler/generic/parms.lisp
+++ b/src/compiler/generic/parms.lisp
@@ -123,7 +123,8 @@
     sb!di::handle-single-step-trap
     fdefinition-object
     #!+win32 sb!kernel::handle-win32-exception
-    #!+sb-thruption sb!thread::run-interruption))
+    #!+sb-thruption sb!thread::run-interruption
+    #!+sb-safepoint sb!thread::enter-foreign-callback))
 
 (defparameter *common-static-symbols*
   '(t
diff --git a/src/runtime/safepoint.c b/src/runtime/safepoint.c
index 8a34a08..a9e578c 100644
--- a/src/runtime/safepoint.c
+++ b/src/runtime/safepoint.c
@@ -979,9 +979,17 @@ callback_wrapper_trampoline(
 #endif
     lispobj arg0, lispobj arg1, lispobj arg2)
 {
+#if defined(LISP_FEATURE_WIN32)
+    pthread_np_notice_thread();
+#endif
     struct thread* th = arch_os_get_current_thread();
-    if (!th)
-        lose("callback invoked in non-lisp thread.  Sorry, that is not supported yet.");
+    if (!th) {                  /* callback invoked in non-lisp thread */
+        init_thread_data scribble;
+        attach_os_thread(&scribble);
+        funcall3(StaticSymbolFunction(ENTER_FOREIGN_CALLBACK), arg0,arg1,arg2);
+        detach_os_thread(&scribble);
+        return;
+    }
 
 #ifdef LISP_FEATURE_WIN32
     /* arg2 is the pointer to a return value, which sits on the stack */
diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 053f486..4d20d0f 100644
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -349,8 +349,9 @@ schedule_thread_post_mortem(struct thread *corpse)
 
 # endif /* !IMMEDIATE_POST_MORTEM */
 
+/* Note: scribble must be stack-allocated */
 static void
-init_new_thread(struct thread *th, init_thread_data *scribble)
+init_new_thread(struct thread *th, init_thread_data *scribble, int guardp)
 {
     int lock_ret;
 
@@ -361,7 +362,8 @@ init_new_thread(struct thread *th, init_thread_data *scribble)
     }
 
     th->os_thread=thread_self();
-    protect_control_stack_guard_page(1, NULL);
+    if (guardp)
+        protect_control_stack_guard_page(1, NULL);
     protect_binding_stack_guard_page(1, NULL);
     protect_alien_stack_guard_page(1, NULL);
     /* Since GC can only know about this thread from the all_threads
@@ -369,7 +371,7 @@ init_new_thread(struct thread *th, init_thread_data *scribble)
      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
      * it is not). */
 #ifdef LISP_FEATURE_SB_SAFEPOINT
-    *th->csp_around_foreign_call = (lispobj)&lock_ret;
+    *th->csp_around_foreign_call = (lispobj)scribble;
 #endif
     lock_ret = pthread_mutex_lock(&all_threads_lock);
     gc_assert(lock_ret == 0);
@@ -449,6 +451,15 @@ undo_init_new_thread(struct thread *th, init_thread_data *scribble)
     TlsSetValue(OUR_TLS_INDEX,NULL);
 #endif
 
+    /* Undo the association of the current pthread to its `struct thread',
+     * such that we can call arch_os_get_current_thread() later in this
+     * thread and cleanly get back NULL. */
+#ifdef LISP_FEATURE_GCC_TLS
+    current_thread = NULL;
+#else
+    pthread_setspecific(specials, NULL);
+#endif
+
     schedule_thread_post_mortem(th);
 }
 
@@ -471,7 +482,7 @@ new_thread_trampoline(struct thread *th)
 
     lispobj function = th->no_tls_value_marker;
     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
-    init_new_thread(th, &scribble);
+    init_new_thread(th, &scribble, 1);
     result = funcall0(function);
     undo_init_new_thread(th, &scribble);
 
@@ -479,6 +490,67 @@ new_thread_trampoline(struct thread *th)
     return result;
 }
 
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+static struct thread *create_thread_struct(lispobj);
+
+void
+attach_os_thread(init_thread_data *scribble)
+{
+    os_thread_t os = pthread_self();
+    odxprint(misc, "attach_os_thread: attaching to %p", os);
+
+    struct thread *th = create_thread_struct(NIL);
+    block_deferrable_signals(0, &scribble->oldset);
+    th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
+    /* We don't actually want a pthread_attr here, but rather than add
+     * `if's to the post-mostem, let's just keep that code happy by
+     * keeping it initialized: */
+    pthread_attr_init(th->os_attr);
+
+#ifndef LISP_FEATURE_WIN32
+    /* On windows, arch_os_thread_init will take care of finding the
+     * stack. */
+    pthread_attr_t attr;
+    int pthread_getattr_np(pthread_t, pthread_attr_t *);
+    pthread_getattr_np(os, &attr);
+    void *stack_addr;
+    size_t stack_size;
+    pthread_attr_getstack(&attr, &stack_addr, &stack_size);
+    th->control_stack_start = stack_addr;
+    th->control_stack_end = (void *) (((uintptr_t) stack_addr) + stack_size);
+#endif
+
+    init_new_thread(th, scribble, 0);
+
+    /* We will be calling into Lisp soon, and the functions being called
+     * recklessly ignore the comment in target-thread which says that we
+     * must be careful to not cause GC while initializing a new thread.
+     * Since we first need to create a fresh thread object, it's really
+     * tempting to just perform such unsafe allocation though.  So let's
+     * at least try to suppress GC before consing, and hope that it
+     * works: */
+    SetSymbolValue(GC_INHIBIT, T, th);
+
+    uword_t stacksize
+        = (uword_t) th->control_stack_end - (uword_t) th->control_stack_start;
+    odxprint(misc, "attach_os_thread: attached %p as %p (0x%lx bytes stack)",
+             os, th, (long) stacksize);
+}
+
+void
+detach_os_thread(init_thread_data *scribble)
+{
+    struct thread *th = arch_os_get_current_thread();
+    odxprint(misc, "detach_os_thread: detaching");
+
+    undo_init_new_thread(th, scribble);
+
+    odxprint(misc, "deattach_os_thread: detached");
+    pthread_setspecific(lisp_thread, (void *)0);
+    thread_sigmask(SIG_SETMASK, &scribble->oldset, 0);
+}
+# endif /* safepoint */
+
 #endif /* LISP_FEATURE_SB_THREAD */
 
 static void
diff --git a/src/runtime/thread.h b/src/runtime/thread.h
index dd36df5..8bde9ba 100644
--- a/src/runtime/thread.h
+++ b/src/runtime/thread.h
@@ -338,10 +338,10 @@ extern kern_return_t mach_lisp_thread_destroy(struct thread *thread);
 #endif
 
 typedef struct init_thread_data {
+    sigset_t oldset;
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     struct gcing_safety safety;
 #endif
-    void *dummy;
 } init_thread_data;
 
 #ifdef LISP_FEATURE_SB_SAFEPOINT
@@ -419,6 +419,9 @@ void pop_gcing_safety(struct gcing_safety *from)
 
 int check_pending_thruptions(os_context_t *ctx);
 
+void attach_os_thread(init_thread_data *);
+void detach_os_thread(init_thread_data *);
+
 #endif
 
 extern void create_initial_thread(lispobj);

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  d80e517dc02941c51b8732a9a449eaac0c388c94 (commit)
      from  de3bfc084239fa962ef001eaa68e5b6f4b9bbf81 (commit)

- Log -----------------------------------------------------------------
commit d80e517dc02941c51b8732a9a449eaac0c388c94
Author: David Lichteblau <david@...>
Date:   Fri Dec 21 20:27:33 2012 +0100

    Re-complicate all_threads check in arch_os_get_current_thread
    
    This check used to be x86-only, and apparently for good reason.
    Make it so again.
---
 src/runtime/thread.h |    7 ++++---
 1 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/src/runtime/thread.h b/src/runtime/thread.h
index 6de8f89..dd36df5 100644
--- a/src/runtime/thread.h
+++ b/src/runtime/thread.h
@@ -303,9 +303,10 @@ static inline struct thread *arch_os_get_current_thread(void)
     return me;
 
 #else
-    if (!all_threads)
-        /* no need to bother */
-        return 0;
+
+# if defined(LISP_FEATURE_X86)
+    if (!all_threads) return 0;
+#endif
 
     /* Otherwise, use pthreads to find the right value.  We do not load
      * directly from %fs:this even on x86 platforms (like Linux and

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  de3bfc084239fa962ef001eaa68e5b6f4b9bbf81 (commit)
      from  e32906fedb6a32b0b237e542ce93e5187c88c4ee (commit)

- Log -----------------------------------------------------------------
commit de3bfc084239fa962ef001eaa68e5b6f4b9bbf81
Author: Nathan Froyd <froydnj@...>
Date:   Wed Dec 19 23:31:23 2012 -0500

    adjust DATA-VECTOR-FROM-INITS to avoid full calls to MAKE-ARRAY when possible
    
    We don't need to do full calls to MAKE-ARRAY in certain cases for
    ADJUST-ARRAY now, which avoids calls to SUBTYPEP and friends.  This
    change significantly speeds up ADJUST-ARRAY for common cases, like the
    calls made by VECTOR-PUSH-EXTEND.
---
 src/code/array.lisp |   60 +++++++++++++++++++++++++++++++-------------------
 1 files changed, 37 insertions(+), 23 deletions(-)

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 79e7545..7122723 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -133,20 +133,27 @@
        (bit #.sb!vm:complex-bit-vector-widetag)
        (t #.sb!vm:complex-vector-widetag)))))
 
-(defun allocate-vector-with-widetag (widetag length n-bits)
+(defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask)))
+#.(loop for info across sb!vm:*specialized-array-element-type-properties*
+        collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info))
+                       ,(sb!vm:saetp-n-bits info)) into forms
+        finally (return `(progn ,@forms)))
+
+(defun allocate-vector-with-widetag (widetag length &optional n-bits)
   (declare (type (unsigned-byte 8) widetag)
-           (type index length)
-           (type (integer 0 256) n-bits))
-  (allocate-vector widetag length
-                   (ceiling
-                    (* (if (or (= widetag sb!vm:simple-base-string-widetag)
-                               #!+sb-unicode
-                               (= widetag
-                                  sb!vm:simple-character-string-widetag))
-                           (1+ length)
-                           length)
-                       n-bits)
-                    sb!vm:n-word-bits)))
+           (type index length))
+  (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag))))
+    (declare (type (integer 0 256) n-bits))
+    (allocate-vector widetag length
+                     (ceiling
+                      (* (if (or (= widetag sb!vm:simple-base-string-widetag)
+                                 #!+sb-unicode
+                                 (= widetag
+                                    sb!vm:simple-character-string-widetag))
+                             (1+ length)
+                             length)
+                         n-bits)
+                      sb!vm:n-word-bits))))
 
 (defun make-array (dimensions &key
                               (element-type t)
@@ -193,7 +200,7 @@
         (let* ((total-size (reduce #'* dimensions))
                (data (or displaced-to
                          (data-vector-from-inits
-                          dimensions total-size element-type
+                          dimensions total-size element-type nil
                           initial-contents initial-contents-p
                           initial-element initial-element-p)))
                (array (make-array-header
@@ -293,18 +300,23 @@ of specialized arrays is supported."
 ;;; specified array characteristics. Dimensions is only used to pass
 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 ;;; initial-contents.
-(defun data-vector-from-inits (dimensions total-size element-type
+(defun data-vector-from-inits (dimensions total-size
+                               element-type widetag
                                initial-contents initial-contents-p
                                initial-element initial-element-p)
   (when (and initial-contents-p initial-element-p)
     (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
             either MAKE-ARRAY or ADJUST-ARRAY."))
-  (let ((data (if initial-element-p
-                  (make-array total-size
-                              :element-type element-type
-                              :initial-element initial-element)
-                  (make-array total-size
-                              :element-type element-type))))
+  (let ((data (cond
+                (widetag
+                 (allocate-vector-with-widetag widetag total-size))
+                (initial-element-p
+                 (make-array total-size
+                             :element-type element-type
+                             :initial-element initial-element))
+                (t
+                 (make-array total-size
+                             :element-type element-type)))))
     (cond (initial-element-p
            (unless (simple-vector-p data)
              (unless (typep initial-element element-type)
@@ -908,7 +920,7 @@ of specialized arrays is supported."
                          the :INITIAL-ELEMENT or :DISPLACED-TO option."))
              (let* ((array-size (apply #'* dimensions))
                     (array-data (data-vector-from-inits
-                                 dimensions array-size element-type
+                                 dimensions array-size element-type nil
                                  initial-contents initial-contents-p
                                  initial-element initial-element-p)))
                (if (adjustable-array-p array)
@@ -962,6 +974,7 @@ of specialized arrays is supported."
                         (setf new-data
                               (data-vector-from-inits
                                dimensions new-length element-type
+                               (widetag-of old-data)
                                initial-contents initial-contents-p
                                initial-element initial-element-p))
                         ;; Provide :END1 to avoid full call to LENGTH
@@ -989,7 +1002,8 @@ of specialized arrays is supported."
                                          (> new-length old-length))
                                      (data-vector-from-inits
                                       dimensions new-length
-                                      element-type () nil
+                                      element-type
+                                      (widetag-of old-data) () nil
                                       initial-element initial-element-p)
                                      old-data)))
                    (if (or (zerop old-length) (zerop new-length))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  e32906fedb6a32b0b237e542ce93e5187c88c4ee (commit)
      from  daa1d24e742eaabd0c5ce8af3a591779a85e4d2c (commit)

- Log -----------------------------------------------------------------
commit e32906fedb6a32b0b237e542ce93e5187c88c4ee
Author: Nathan Froyd <froydnj@...>
Date:   Wed Dec 19 23:27:32 2012 -0500

    factor out ALLOCATE-VECTOR-WITH-WIDETAG function from MAKE-ARRAY
---
 src/code/array.lisp |   28 ++++++++++++++++------------
 1 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/src/code/array.lisp b/src/code/array.lisp
index c700d7b..79e7545 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -133,6 +133,21 @@
        (bit #.sb!vm:complex-bit-vector-widetag)
        (t #.sb!vm:complex-vector-widetag)))))
 
+(defun allocate-vector-with-widetag (widetag length n-bits)
+  (declare (type (unsigned-byte 8) widetag)
+           (type index length)
+           (type (integer 0 256) n-bits))
+  (allocate-vector widetag length
+                   (ceiling
+                    (* (if (or (= widetag sb!vm:simple-base-string-widetag)
+                               #!+sb-unicode
+                               (= widetag
+                                  sb!vm:simple-character-string-widetag))
+                           (1+ length)
+                           length)
+                       n-bits)
+                    sb!vm:n-word-bits)))
+
 (defun make-array (dimensions &key
                               (element-type t)
                               (initial-element nil initial-element-p)
@@ -159,18 +174,7 @@
           (declare (type (unsigned-byte 8) type)
                    (type (integer 0 256) n-bits))
           (let* ((length (car dimensions))
-                 (array (allocate-vector
-                         type
-                         length
-                         (ceiling
-                          (* (if (or (= type sb!vm:simple-base-string-widetag)
-                                     #!+sb-unicode
-                                     (= type
-                                        sb!vm:simple-character-string-widetag))
-                                 (1+ length)
-                                 length)
-                             n-bits)
-                          sb!vm:n-word-bits))))
+                 (array (allocate-vector-with-widetag type length n-bits)))
             (declare (type index length))
             (when initial-element-p
               (fill array initial-element))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  daa1d24e742eaabd0c5ce8af3a591779a85e4d2c (commit)
      from  43c6634142a96e1d1bab2efe1a39cd8234903c41 (commit)

- Log -----------------------------------------------------------------
commit daa1d24e742eaabd0c5ce8af3a591779a85e4d2c
Author: Nathan Froyd <froydnj@...>
Date:   Wed Dec 19 23:16:01 2012 -0500

    adjust call to REPLACE inside ADJUST-ARRAY
    
    The more information we can provide, the better.
---
 src/code/array.lisp |    3 +++
 1 files changed, 3 insertions(+), 0 deletions(-)

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 90b7a99..c700d7b 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -960,7 +960,10 @@ of specialized arrays is supported."
                                dimensions new-length element-type
                                initial-contents initial-contents-p
                                initial-element initial-element-p))
+                        ;; Provide :END1 to avoid full call to LENGTH
+                        ;; inside REPLACE.
                         (replace new-data old-data
+                                 :end1 new-length
                                  :start2 old-start :end2 old-end))
                        (t (setf new-data
                                 (shrink-vector old-data new-length))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  43c6634142a96e1d1bab2efe1a39cd8234903c41 (commit)
      from  a1019cb2ccde131d2466f2d70076a00059e3c71d (commit)

- Log -----------------------------------------------------------------
commit 43c6634142a96e1d1bab2efe1a39cd8234903c41
Author: Nathan Froyd <froydnj@...>
Date:   Wed Dec 19 23:13:47 2012 -0500

    don't check SUBTYPEP of ELEMENT-TYPE in ADJUST-ARRAY unnecessarily
---
 src/code/array.lisp |    5 +++--
 1 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 8a4ddfe..90b7a99 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -871,7 +871,7 @@ of specialized arrays is supported."
 ;;;; ADJUST-ARRAY
 
 (defun adjust-array (array dimensions &key
-                           (element-type (array-element-type array))
+                           (element-type (array-element-type array) element-type-p)
                            (initial-element nil initial-element-p)
                            (initial-contents nil initial-contents-p)
                            fill-pointer
@@ -884,7 +884,8 @@ of specialized arrays is supported."
     (cond ((/= (the fixnum (length (the list dimensions)))
                (the fixnum (array-rank array)))
            (error "The number of dimensions not equal to rank of array."))
-          ((not (subtypep element-type (array-element-type array)))
+          ((and element-type-p
+                (not (subtypep element-type (array-element-type array))))
            (error "The new element type, ~S, is incompatible with old type."
                   element-type))
           ((and fill-pointer (not (array-has-fill-pointer-p array)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  a1019cb2ccde131d2466f2d70076a00059e3c71d (commit)
      from  053e401f08f5df876707453960f8034661553d05 (commit)

- Log -----------------------------------------------------------------
commit a1019cb2ccde131d2466f2d70076a00059e3c71d
Author: Nathan Froyd <froydnj@...>
Date:   Wed Dec 19 23:10:42 2012 -0500

    lazily compute MIN-EXTENSION for VECTOR-PUSH-EXTEND
    
    This change avoids a full call to LENGTH on every call to VECTOR-PUSH-EXTEND.
---
 src/code/array.lisp |   17 ++++++++---------
 1 files changed, 8 insertions(+), 9 deletions(-)

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 0d44b09..8a4ddfe 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -836,18 +836,17 @@ of specialized arrays is supported."
            (setf (%array-fill-pointer array) (1+ fill-pointer))
            fill-pointer))))
 
-(defun vector-push-extend (new-element
-                           vector
-                           &optional
-                           (min-extension
-                            (let ((length (length vector)))
-                              (min (1+ length)
-                                   (- array-dimension-limit length)))))
-  (declare (fixnum min-extension))
+(defun vector-push-extend (new-element vector &optional min-extension)
+  (declare (type (or null fixnum) min-extension))
   (let ((fill-pointer (fill-pointer vector)))
     (declare (fixnum fill-pointer))
     (when (= fill-pointer (%array-available-elements vector))
-      (adjust-array vector (+ fill-pointer (max 1 min-extension))))
+      (let ((min-extension
+             (or min-extension
+                 (let ((length (length vector)))
+                   (min (1+ length)
+                        (- array-dimension-limit length))))))
+        (adjust-array vector (+ fill-pointer (max 1 min-extension)))))
     ;; disable bounds checking
     (locally (declare (optimize (safety 0)))
       (setf (aref vector fill-pointer) new-element))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  053e401f08f5df876707453960f8034661553d05 (commit)
      from  62964aced3a1480849e0bc9de1b0ca927b2e2475 (commit)

- Log -----------------------------------------------------------------
commit 053e401f08f5df876707453960f8034661553d05
Author: Stas Boukarev <stassats@...>
Date:   Tue Dec 18 21:51:09 2012 +0400

    Fix a typo in the previous commit.
    
    -1 should be ~S.
---
 src/code/toplevel.lisp |    2 +-
 1 files changed, 1 insertions(+), 1 deletions(-)

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index f5a7aa9..d3f523f 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -198,7 +198,7 @@ any non-negative real number."
   (when (or (not (realp seconds))
             (minusp seconds))
     (error 'simple-type-error
-           :format-control "Invalid argument to SLEEP: -1, ~
+           :format-control "Invalid argument to SLEEP: ~S, ~
                             should be a non-negative real."
            :format-arguments (list seconds)
            :datum seconds

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  62964aced3a1480849e0bc9de1b0ca927b2e2475 (commit)
      from  9f53ac7b6e54d0dfeb558ae8e90bf56f3784aecb (commit)

- Log -----------------------------------------------------------------
commit 62964aced3a1480849e0bc9de1b0ca927b2e2475
Author: Stas Boukarev <stassats@...>
Date:   Tue Dec 18 21:38:24 2012 +0400

    Better error message for SLEEP.
    
    Add explicit-check to defknown, sleep already explicitly checks the
    argument.
    Slightly improve the produced error message.
---
 src/code/toplevel.lisp |    3 ++-
 src/compiler/fndb.lisp |    2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index a72e064..f5a7aa9 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -198,7 +198,8 @@ any non-negative real number."
   (when (or (not (realp seconds))
             (minusp seconds))
     (error 'simple-type-error
-           :format-control "invalid argument to SLEEP: ~S"
+           :format-control "Invalid argument to SLEEP: -1, ~
+                            should be a non-negative real."
            :format-arguments (list seconds)
            :datum seconds
            :expected-type '(real 0)))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index a83a568..ac1482d 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1367,7 +1367,7 @@
 (defknown (get-internal-run-time get-internal-real-time)
   () internal-time (flushable))
 
-(defknown sleep ((or (rational 0) (float 0.0))) null)
+(defknown sleep ((real 0)) null (explicit-check))
 
 ;;; Even though ANSI defines LISP-IMPLEMENTATION-TYPE and
 ;;; LISP-IMPLEMENTATION-VERSION to possibly punt and return NIL, we

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  9f53ac7b6e54d0dfeb558ae8e90bf56f3784aecb (commit)
      from  fe6da9f355488152649de48885b96205043c0f82 (commit)

- Log -----------------------------------------------------------------
commit 9f53ac7b6e54d0dfeb558ae8e90bf56f3784aecb
Author: Stas Boukarev <stassats@...>
Date:   Tue Dec 18 19:04:15 2012 +0400

    make.sh --help no longer runs clean.sh
    
    Fixes lp#937001
---
 NEWS           |    1 +
 make-config.sh |    4 ++++
 make.sh        |    4 ----
 3 files changed, 5 insertions(+), 4 deletions(-)

diff --git a/NEWS b/NEWS
index e4aa65e..13036cc 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,7 @@ changes relative to sbcl-1.1.2:
     (lp#727625)
   * bug fix: fasls are now once again directly executable (on platforms
     supporting shebang lines, with a suitably-installed sbcl).
+  * bug fix: make.sh --help no longer runs clean.sh. (lp#937001)
 
 changes in sbcl-1.1.2 relative to sbcl-1.1.1:
   * notice: System requirements for SBCL on Microsoft Windows: Windows NT 5.1
diff --git a/make-config.sh b/make-config.sh
index 1b86204..1a0a547 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -208,6 +208,10 @@ EOF
   exit 1
 fi
 
+# Running make.sh with different options without clean.sh in the middle
+# can break things.
+sh clean.sh
+
 mkdir -p output
 # Save prefix for make and install.sh.
 echo "SBCL_PREFIX='$SBCL_PREFIX'" > output/prefix.def
diff --git a/make.sh b/make.sh
index 77494c6..f10db34 100755
--- a/make.sh
+++ b/make.sh
@@ -20,10 +20,6 @@ export LANG LC_ALL
 # provided with absolutely no warranty. See the COPYING and CREDITS
 # files for more information.
 
-# Running make.sh with different options without clean.sh in the middle
-# can break things.
-sh clean.sh
-
 # If you're cross-compiling, make-config.sh should "do the right
 # thing" when run on the target machine, with the minor caveat that
 # any --xc-host parameter should be suitable for the host machine

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  fe6da9f355488152649de48885b96205043c0f82 (commit)
      from  9644b3bcfc539ab201da9d3251a3cc3ebc24d457 (commit)

- Log -----------------------------------------------------------------
commit fe6da9f355488152649de48885b96205043c0f82
Author: Stas Boukarev <stassats@...>
Date:   Mon Dec 17 23:07:22 2012 +0400

    sb-rotate-byte: Don't use :if-component-dep-fails.
    
    Newer ASDF doesn't support it anymore.
---
 contrib/sb-rotate-byte/sb-rotate-byte.asd |   15 +++++++--------
 1 files changed, 7 insertions(+), 8 deletions(-)

diff --git a/contrib/sb-rotate-byte/sb-rotate-byte.asd b/contrib/sb-rotate-byte/sb-rotate-byte.asd
index 908392d..036f1ba 100644
--- a/contrib/sb-rotate-byte/sb-rotate-byte.asd
+++ b/contrib/sb-rotate-byte/sb-rotate-byte.asd
@@ -14,16 +14,15 @@
    (:module "vm"
             :depends-on ("compiler")
             :components
-            ((:file "x86-vm"
-                    :in-order-to ((compile-op (feature :x86))))
-             (:file "x86-64-vm"
-                    :in-order-to ((compile-op (feature :x86-64))))
-             (:file "ppc-vm"
-                    :in-order-to ((compile-op (feature :ppc)))))
+            (#+x86
+             (:file "x86-vm")
+             #+x86-64
+             (:file "x86-64-vm")
+             #+ppc
+             (:file "ppc-vm"))
             :pathname
             #+sb-building-contrib #p"SYS:CONTRIB;SB-ROTATE-BYTE;"
-            #-sb-building-contrib #.(make-pathname :directory '(:relative))
-            :if-component-dep-fails :ignore)
+            #-sb-building-contrib #.(make-pathname :directory '(:relative)))
    (:file "rotate-byte" :depends-on ("compiler"))))
 
 (defmethod perform :after ((o load-op) (c (eql (find-system :sb-rotate-byte))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  9644b3bcfc539ab201da9d3251a3cc3ebc24d457 (commit)
      from  f21d139cd90695962174882c27585c02511c3027 (commit)

- Log -----------------------------------------------------------------
commit 9644b3bcfc539ab201da9d3251a3cc3ebc24d457
Author: David Lichteblau <david@...>
Date:   Wed Dec 12 14:12:50 2012 +0100

    In x86 arch_os_get_current_thread(), do not load from %fs
    
    Simplify arch_os_get_current_thread() such that %fs is not being
    loaded directly even on platforms which preserve it reliably (in
    particular, Linux/x86 and Solaris/x86).
    
    Aside from a code simplification and reduction of cross-platform
    differences, this change is an improvement in the following way:
    
    If arch_os_get_current_thread() gets called in a non-Lisp pthread,
    it now returns NULL cleanly even on the platforms mentioned above.
    
    On the other platforms, keep the support for restoring %fs, but
    refactor to remove code duplication with arch_os_thread_init().
    Coalesce the two differently-spelled Lisp features for this case
    into one.
---
 base-target-features.lisp-expr |    2 +-
 make-config.sh                 |    2 +-
 src/runtime/arch.h             |    3 ++
 src/runtime/thread.h           |   69 +++++++++++++++++-----------------------
 src/runtime/x86-bsd-os.c       |   20 +++++++++--
 src/runtime/x86-darwin-os.c    |   23 +++++++++----
 6 files changed, 66 insertions(+), 53 deletions(-)

diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr
index 22530df..9ba7b4d 100644
--- a/base-target-features.lisp-expr
+++ b/base-target-features.lisp-expr
@@ -238,7 +238,7 @@
  ;; thread local storage) is not reliably preserved in signal
  ;; handlers, so we need to restore its value from the pthread thread
  ;; local storage.
- ; :restore-tls-segment-register-from-tls
+ ; :restore-fs-segment-register-from-tls
 
  ;; On some x86oid operating systems (darwin) SIGTRAP is not reliably
  ;; delivered for the INT3 instruction, so we use the UD2 instruction
diff --git a/make-config.sh b/make-config.sh
index 3897191..1b86204 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -478,7 +478,7 @@ case "$sbcl_os" in
                 printf ' :freebsd' >> $ltf
                 printf ' :gcc-tls' >> $ltf
                 if [ $sbcl_arch = "x86" ]; then
-                    printf ' :restore-tls-segment-register-from-context' >> $ltf
+                    printf ' :restore-fs-segment-register-from-tls' >> $ltf
                 fi
                 link_or_copy Config.$sbcl_arch-freebsd Config
                 ;;
diff --git a/src/runtime/arch.h b/src/runtime/arch.h
index 1a8cf69..c8ef480 100644
--- a/src/runtime/arch.h
+++ b/src/runtime/arch.h
@@ -35,6 +35,9 @@ extern void arch_do_displaced_inst(os_context_t *context,
                                    unsigned int orig_inst);
 
 extern int arch_os_thread_init(struct thread *thread);
+#if defined(LISP_FEATURE_X86) && defined(LISP_FEATURE_SB_THREAD)
+extern void arch_os_load_ldt(struct thread *thread);
+#endif
 extern int arch_os_thread_cleanup(struct thread *thread);
 
 extern lispobj funcall0(lispobj function);
diff --git a/src/runtime/thread.h b/src/runtime/thread.h
index ec295fc..6de8f89 100644
--- a/src/runtime/thread.h
+++ b/src/runtime/thread.h
@@ -294,51 +294,40 @@ static inline struct thread* arch_os_get_current_thread()
 
 static inline struct thread *arch_os_get_current_thread(void)
 {
-#if defined(LISP_FEATURE_SB_THREAD)
-#if defined(LISP_FEATURE_X86)
+#if !defined(LISP_FEATURE_SB_THREAD)
+     return all_threads;
+
+#elif defined(LISP_FEATURE_X86) && defined(LISP_FEATURE_WIN32)
     register struct thread *me=0;
-#if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)
     __asm__ ("movl %%fs:0xE10+(4*63), %0" : "=r"(me) :);
     return me;
-#endif
-    if(all_threads) {
-#if defined(LISP_FEATURE_DARWIN) && defined(LISP_FEATURE_RESTORE_FS_SEGMENT_REGISTER_FROM_TLS)
-        sel_t sel;
-        struct thread *th = pthread_getspecific(specials);
-        sel.index = th->tls_cookie;
-        sel.rpl = USER_PRIV;
-        sel.ti = SEL_LDT;
-        __asm__ __volatile__ ("movw %w0, %%fs" : : "r"(sel));
-#elif defined(LISP_FEATURE_FREEBSD)
-#ifdef LISP_FEATURE_GCC_TLS
-        struct thread *th = current_thread;
-#else
-        struct thread *th = pthread_getspecific(specials);
-#endif
-#ifdef LISP_FEATURE_RESTORE_TLS_SEGMENT_REGISTER_FROM_TLS
-        unsigned int sel = LSEL(th->tls_cookie, SEL_UPL);
-        unsigned int fs = rfs();
 
-        /* Load FS only if it's necessary.  Modifying a selector
-         * causes privilege checking and it takes long time. */
-        if (fs != sel)
-            load_fs(sel);
-#endif
-        return th;
-#endif
-        __asm__ ("movl %%fs:%c1,%0" : "=r" (me)
-                 : "i" (offsetof (struct thread,this)));
-    }
-    return me;
-#else
-#ifdef LISP_FEATURE_GCC_TLS
-    return current_thread;
-#else
-    return pthread_getspecific(specials);
-#endif
-#endif /* x86 */
 #else
-     return all_threads;
+    if (!all_threads)
+        /* no need to bother */
+        return 0;
+
+    /* Otherwise, use pthreads to find the right value.  We do not load
+     * directly from %fs:this even on x86 platforms (like Linux and
+     * Solaris) with dependable %fs, because we want to return NULL if
+     * called by a non-Lisp thread, and %fs would not be initialized
+     * suitably in that case. */
+    struct thread *th;
+# ifdef LISP_FEATURE_GCC_TLS
+    th = current_thread;
+# else
+    th = pthread_getspecific(specials);
+# endif
+
+# if defined(LISP_FEATURE_RESTORE_FS_SEGMENT_REGISTER_FROM_TLS)
+    /* If enabled by make-config (currently Darwin and FreeBSD only),
+     * re-setup %fs.  This is an out-of-line call, and potentially
+     * expensive.*/
+    if (th)
+        arch_os_load_ldt(th);
+# endif
+
+    return th;
 #endif
 }
 
diff --git a/src/runtime/x86-bsd-os.c b/src/runtime/x86-bsd-os.c
index 8b62584..fe75566 100644
--- a/src/runtime/x86-bsd-os.c
+++ b/src/runtime/x86-bsd-os.c
@@ -157,11 +157,24 @@ void set_data_desc_addr(struct segment_descriptor* desc, void* addr)
 
 #endif
 
+#ifdef LISP_FEATURE_SB_THREAD
+void
+arch_os_load_ldt(struct thread *thread)
+{
+    int sel = LSEL(thread->tls_cookie, SEL_UPL);
+    unsigned int fs = rfs();
+
+    /* Load FS only if it's necessary.  Modifying a selector
+     * causes privilege checking and it takes long time. */
+    if (fs != sel)
+        load_fs(sel);
+}
+#endif
+
 int arch_os_thread_init(struct thread *thread) {
 
 #ifdef LISP_FEATURE_SB_THREAD
     int n;
-    int sel;
 
     struct segment_descriptor ldt_entry = { 0, 0, SDT_MEMRW, SEL_UPL, 1,
                                             0, 0, 1, 0, 0 };
@@ -175,10 +188,9 @@ int arch_os_thread_init(struct thread *thread) {
         lose("unexpected i386_set_ldt(..) failure\n");
     }
     FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", n));
-    sel =  LSEL(n, SEL_UPL);
-    load_fs(sel);
-
     thread->tls_cookie=n;
+    arch_os_load_ldt(thread);
+
 #ifdef LISP_FEATURE_GCC_TLS
     current_thread = thread;
 #else
diff --git a/src/runtime/x86-darwin-os.c b/src/runtime/x86-darwin-os.c
index 323e549..8489322 100644
--- a/src/runtime/x86-darwin-os.c
+++ b/src/runtime/x86-darwin-os.c
@@ -44,10 +44,23 @@ void set_data_desc_addr(data_desc_t* desc, void* addr)
 
 #endif
 
+#ifdef LISP_FEATURE_SB_THREAD
+void
+arch_os_load_ldt(struct thread *thread)
+{
+    sel_t sel;
+
+    sel.index = thread->tls_cookie;
+    sel.rpl = USER_PRIV;
+    sel.ti = SEL_LDT;
+
+    __asm__ __volatile__ ("mov %0, %%fs" : : "r"(sel));
+}
+#endif
+
 int arch_os_thread_init(struct thread *thread) {
 #ifdef LISP_FEATURE_SB_THREAD
     int n;
-    sel_t sel;
 
     data_desc_t ldt_entry = { 0, 0, 0, DESC_DATA_WRITE,
                               3, 1, 0, DESC_DATA_32B, DESC_GRAN_BYTE, 0 };
@@ -65,13 +78,9 @@ int arch_os_thread_init(struct thread *thread) {
     thread_mutex_unlock(&modify_ldt_lock);
 
     FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", n));
-    sel.index = n;
-    sel.rpl = USER_PRIV;
-    sel.ti = SEL_LDT;
-
-    __asm__ __volatile__ ("mov %0, %%fs" : : "r"(sel));
-
     thread->tls_cookie=n;
+    arch_os_load_ldt(thread);
+
     pthread_setspecific(specials,thread);
 #endif
 #ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  f21d139cd90695962174882c27585c02511c3027 (commit)
      from  789406b1a4f6d546f426eb4f51aa6a10d432c4dd (commit)

- Log -----------------------------------------------------------------
commit f21d139cd90695962174882c27585c02511c3027
Author: David Lichteblau <david@...>
Date:   Wed Dec 5 18:36:10 2012 +0100

    Split up new_thread_trampoline
    
    Refactor it into two independent pieces for initialization and
    deinitialization around the point of its central funcall.
---
 src/runtime/thread.c |   69 ++++++++++++++++++++++++++++++++-----------------
 src/runtime/thread.h |    7 +++++
 2 files changed, 52 insertions(+), 24 deletions(-)

diff --git a/src/runtime/thread.c b/src/runtime/thread.c
index 838a187..053f486 100644
--- a/src/runtime/thread.c
+++ b/src/runtime/thread.c
@@ -349,25 +349,12 @@ schedule_thread_post_mortem(struct thread *corpse)
 
 # endif /* !IMMEDIATE_POST_MORTEM */
 
-/* this is the first thing that runs in the child (which is why the
- * silly calling convention).  Basically it calls the user's requested
- * lisp function after doing arch_os_thread_init and whatever other
- * bookkeeping needs to be done
- */
-int
-new_thread_trampoline(struct thread *th)
+static void
+init_new_thread(struct thread *th, init_thread_data *scribble)
 {
-    lispobj function;
-    int result, lock_ret;
+    int lock_ret;
 
-    FSHOW((stderr,"/creating thread %lu\n", thread_self()));
-    check_deferrables_blocked_or_lose(0);
-#ifndef LISP_FEATURE_SB_SAFEPOINT
-    check_gc_signals_unblocked_or_lose(0);
-#endif
     pthread_setspecific(lisp_thread, (void *)1);
-    function = th->no_tls_value_marker;
-    th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
     if(arch_os_thread_init(th)==0) {
         /* FIXME: handle error */
         lose("arch_os_thread_init failed\n");
@@ -382,7 +369,7 @@ new_thread_trampoline(struct thread *th)
      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
      * it is not). */
 #ifdef LISP_FEATURE_SB_SAFEPOINT
-    *th->csp_around_foreign_call = (lispobj)&function;
+    *th->csp_around_foreign_call = (lispobj)&lock_ret;
 #endif
     lock_ret = pthread_mutex_lock(&all_threads_lock);
     gc_assert(lock_ret == 0);
@@ -397,19 +384,28 @@ new_thread_trampoline(struct thread *th)
     gc_state_lock();
     gc_state_wait(GC_NONE);
     gc_state_unlock();
-    WITH_GC_AT_SAFEPOINTS_ONLY() {
-        result = funcall0(function);
-        block_blockable_signals(0, 0);
-        gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
-    }
+    push_gcing_safety(&scribble->safety);
+#endif
+}
+
+static void
+undo_init_new_thread(struct thread *th, init_thread_data *scribble)
+{
+    int lock_ret;
+
+    /* Kludge: Changed the order of some steps between the safepoint/
+     * non-safepoint versions of this code.  Can we unify this more?
+     */
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    block_blockable_signals(0, 0);
+    gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+    pop_gcing_safety(&scribble->safety);
     lock_ret = pthread_mutex_lock(&all_threads_lock);
     gc_assert(lock_ret == 0);
     unlink_thread(th);
     lock_ret = pthread_mutex_unlock(&all_threads_lock);
     gc_assert(lock_ret == 0);
 #else
-    result = funcall0(function);
-
     /* Block GC */
     block_blockable_signals(0, 0);
     set_thread_state(th, STATE_DEAD);
@@ -454,6 +450,31 @@ new_thread_trampoline(struct thread *th)
 #endif
 
     schedule_thread_post_mortem(th);
+}
+
+/* this is the first thing that runs in the child (which is why the
+ * silly calling convention).  Basically it calls the user's requested
+ * lisp function after doing arch_os_thread_init and whatever other
+ * bookkeeping needs to be done
+ */
+int
+new_thread_trampoline(struct thread *th)
+{
+    int result;
+    init_thread_data scribble;
+
+    FSHOW((stderr,"/creating thread %lu\n", thread_self()));
+    check_deferrables_blocked_or_lose(0);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
+    check_gc_signals_unblocked_or_lose(0);
+#endif
+
+    lispobj function = th->no_tls_value_marker;
+    th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
+    init_new_thread(th, &scribble);
+    result = funcall0(function);
+    undo_init_new_thread(th, &scribble);
+
     FSHOW((stderr,"/exiting thread %lu\n", thread_self()));
     return result;
 }
diff --git a/src/runtime/thread.h b/src/runtime/thread.h
index 88b03bc..ec295fc 100644
--- a/src/runtime/thread.h
+++ b/src/runtime/thread.h
@@ -347,6 +347,13 @@ extern kern_return_t mach_lisp_thread_init(struct thread *thread);
 extern kern_return_t mach_lisp_thread_destroy(struct thread *thread);
 #endif
 
+typedef struct init_thread_data {
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    struct gcing_safety safety;
+#endif
+    void *dummy;
+} init_thread_data;
+
 #ifdef LISP_FEATURE_SB_SAFEPOINT
 void thread_in_safety_transition(os_context_t *ctx);
 void thread_in_lisp_raised(os_context_t *ctx);

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  789406b1a4f6d546f426eb4f51aa6a10d432c4dd (commit)
      from  77acf5b7dce7ecfcc8a66b5f3d527b10cdd74dc1 (commit)

- Log -----------------------------------------------------------------
commit 789406b1a4f6d546f426eb4f51aa6a10d432c4dd
Author: David Lichteblau <david@...>
Date:   Wed Dec 5 18:05:06 2012 +0100

    Factor INITIAL-THREAD-FUNCTION out of MAKE-THREAD
---
 src/code/target-thread.lisp |  157 ++++++++++++++++++++++--------------------
 1 files changed, 82 insertions(+), 75 deletions(-)

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 8948d3d..c668eea 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1349,6 +1349,83 @@ have the foreground next."
 
 ;;;; The beef
 
+#!+sb-thread
+(defun initial-thread-function-trampoline
+    (thread setup-sem real-function arguments)
+  ;; In time we'll move some of the binding presently done in C here
+  ;; too.
+  ;;
+  ;; KLUDGE: Here we have a magic list of variables that are not
+  ;; thread-safe for one reason or another.  As people report problems
+  ;; with the thread safety of certain variables, (e.g. "*print-case* in
+  ;; multiple threads broken", sbcl-devel 2006-07-14), we add a few more
+  ;; bindings here.  The Right Thing is probably some variant of
+  ;; Allegro's *cl-default-special-bindings*, as that is at least
+  ;; accessible to users to secure their own libraries.
+  ;;   --njf, 2006-07-15
+  ;;
+  ;; As it is, this lambda must not cons until we are ready to run
+  ;; GC. Be very careful.
+  (let* ((*current-thread* thread)
+         (*restart-clusters* nil)
+         (*handler-clusters* (sb!kernel::initial-handler-clusters))
+         (*condition-restarts* nil)
+         (*exit-in-process* nil)
+         (sb!impl::*deadline* nil)
+         (sb!impl::*deadline-seconds* nil)
+         (sb!impl::*step-out* nil)
+         ;; internal printer variables
+         (sb!impl::*previous-case* nil)
+         (sb!impl::*previous-readtable-case* nil)
+         (sb!impl::*internal-symbol-output-fun* nil)
+         (sb!impl::*descriptor-handlers* nil)) ; serve-event
+    ;; Binding from C
+    (setf sb!vm:*alloc-signal* *default-alloc-signal*)
+    (setf (thread-os-thread thread) (current-thread-os-thread))
+    (with-mutex ((thread-result-lock thread))
+      (with-all-threads-lock
+          (push thread *all-threads*))
+      (with-session-lock (*session*)
+        (push thread (session-threads *session*)))
+      (setf (thread-%alive-p thread) t)
+      (signal-semaphore setup-sem)
+      ;; Using handling-end-of-the-world would be a bit tricky
+      ;; due to other catches and interrupts, so we essentially
+      ;; re-implement it here. Once and only once more.
+      (catch 'sb!impl::toplevel-catcher
+        (catch 'sb!impl::%end-of-the-world
+          (catch '%abort-thread
+            (with-simple-restart
+                (abort "~@<Abort thread (~A)~@:>" *current-thread*)
+              (without-interrupts
+                  (unwind-protect
+                       (with-local-interrupts
+                           (sb!unix::unblock-deferrable-signals)
+                         (setf (thread-result thread)
+                               (prog1
+                                   (cons t
+                                         (multiple-value-list
+                                          (unwind-protect
+                                               (catch '%return-from-thread
+                                                 (apply real-function arguments))
+                                            (when *exit-in-process*
+                                              (sb!impl::call-exit-hooks)))))
+                                 #!+sb-safepoint
+                                 (sb!kernel::gc-safepoint))))
+                    ;; We're going down, can't handle interrupts
+                    ;; sanely anymore. GC remains enabled.
+                    (block-deferrable-signals)
+                    ;; We don't want to run interrupts in a dead
+                    ;; thread when we leave WITHOUT-INTERRUPTS.
+                    ;; This potentially causes important
+                    ;; interupts to be lost: SIGINT comes to
+                    ;; mind.
+                    (setq *interrupt-pending* nil)
+                    #!+sb-thruption
+                    (setq *thruption-pending* nil)
+                    (handle-thread-exit thread)))))))))
+  (values))
+
 (defun make-thread (function &key name arguments ephemeral)
   #!+sb-doc
   "Create a new thread of NAME that runs FUNCTION with the argument
@@ -1376,81 +1453,11 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
                                  arguments
                                  (list arguments)))
               (initial-function
-                (named-lambda initial-thread-function ()
-                  ;; In time we'll move some of the binding presently done in C
-                  ;; here too.
-                  ;;
-                  ;; KLUDGE: Here we have a magic list of variables that are
-                  ;; not thread-safe for one reason or another.  As people
-                  ;; report problems with the thread safety of certain
-                  ;; variables, (e.g. "*print-case* in multiple threads
-                  ;; broken", sbcl-devel 2006-07-14), we add a few more
-                  ;; bindings here.  The Right Thing is probably some variant
-                  ;; of Allegro's *cl-default-special-bindings*, as that is at
-                  ;; least accessible to users to secure their own libraries.
-                  ;;   --njf, 2006-07-15
-                  ;;
-                  ;; As it is, this lambda must not cons until we are ready
-                  ;; to run GC. Be very careful.
-                  (let* ((*current-thread* thread)
-                         (*restart-clusters* nil)
-                         (*handler-clusters* (sb!kernel::initial-handler-clusters))
-                         (*condition-restarts* nil)
-                         (*exit-in-process* nil)
-                         (sb!impl::*deadline* nil)
-                         (sb!impl::*deadline-seconds* nil)
-                         (sb!impl::*step-out* nil)
-                         ;; internal printer variables
-                         (sb!impl::*previous-case* nil)
-                         (sb!impl::*previous-readtable-case* nil)
-                         (sb!impl::*internal-symbol-output-fun* nil)
-                         (sb!impl::*descriptor-handlers* nil)) ; serve-event
-                    ;; Binding from C
-                    (setf sb!vm:*alloc-signal* *default-alloc-signal*)
-                    (setf (thread-os-thread thread) (current-thread-os-thread))
-                    (with-mutex ((thread-result-lock thread))
-                      (with-all-threads-lock
-                        (push thread *all-threads*))
-                      (with-session-lock (*session*)
-                        (push thread (session-threads *session*)))
-                      (setf (thread-%alive-p thread) t)
-                      (signal-semaphore setup-sem)
-                      ;; Using handling-end-of-the-world would be a bit tricky
-                      ;; due to other catches and interrupts, so we essentially
-                      ;; re-implement it here. Once and only once more.
-                      (catch 'sb!impl::toplevel-catcher
-                        (catch 'sb!impl::%end-of-the-world
-                          (catch '%abort-thread
-                            (with-simple-restart
-                                (abort "~@<Abort thread (~A)~@:>" *current-thread*)
-                              (without-interrupts
-                                (unwind-protect
-                                     (with-local-interrupts
-                                       (sb!unix::unblock-deferrable-signals)
-                                       (setf (thread-result thread)
-                                             (prog1
-                                                 (cons t
-                                                       (multiple-value-list
-                                                        (unwind-protect
-                                                             (catch '%return-from-thread
-                                                               (apply real-function arguments))
-                                                          (when *exit-in-process*
-                                                            (sb!impl::call-exit-hooks)))))
-                                               #!+sb-safepoint
-                                               (sb!kernel::gc-safepoint))))
-                                  ;; We're going down, can't handle interrupts
-                                  ;; sanely anymore. GC remains enabled.
-                                  (block-deferrable-signals)
-                                  ;; We don't want to run interrupts in a dead
-                                  ;; thread when we leave WITHOUT-INTERRUPTS.
-                                  ;; This potentially causes important
-                                  ;; interupts to be lost: SIGINT comes to
-                                  ;; mind.
-                                  (setq *interrupt-pending* nil)
-                                  #!+sb-thruption
-                                  (setq *thruption-pending* nil)
-                                  (handle-thread-exit thread)))))))))
-                  (values))))
+               (named-lambda initial-thread-function ()
+                 ;; As it is, this lambda must not cons until we are ready
+                 ;; to run GC. Be very careful.
+                 (initial-thread-function-trampoline
+                  thread setup-sem real-function arguments))))
          ;; If the starting thread is stopped for gc before it signals the
          ;; semaphore then we'd be stuck.
          (assert (not *gc-inhibit*))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  77acf5b7dce7ecfcc8a66b5f3d527b10cdd74dc1 (commit)
      from  17e630f7dcb8f8a46361f5a09a872a280449ac33 (commit)

- Log -----------------------------------------------------------------
commit 77acf5b7dce7ecfcc8a66b5f3d527b10cdd74dc1
Author: Stas Boukarev <stassats@...>
Date:   Mon Dec 17 17:35:05 2012 +0400

    Fix a typo.
    
    In the previous commit, varaibles -> variables.
    
    Adjust NEWS by adding lp#n.
---
 NEWS                  |    1 +
 src/runtime/runtime.c |    2 +-
 2 files changed, 2 insertions(+), 1 deletions(-)

diff --git a/NEWS b/NEWS
index 81a6e6e..e4aa65e 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.1.2:
   * enhancement: warnings about bad locale settings, LANG, LC_CTYPE, etc.
+    (lp#727625)
   * bug fix: fasls are now once again directly executable (on platforms
     supporting shebang lines, with a suitably-installed sbcl).
 
diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c
index 7548e1c..3bc18ee 100644
--- a/src/runtime/runtime.c
+++ b/src/runtime/runtime.c
@@ -362,7 +362,7 @@ void setup_locale()
 #ifndef LISP_FEATURE_WIN32
 
     fprintf(stderr, "WARNING: Setting locale failed.\n");
-    fprintf(stderr, "  Check the following varaibles for correct values:");
+    fprintf(stderr, "  Check the following variables for correct values:");
 
     if (setlocale(LC_CTYPE, "") == NULL) {
       print_locale_variable("LC_ALL");

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  17e630f7dcb8f8a46361f5a09a872a280449ac33 (commit)
      from  219457dafac6f2df2c53c1fb7de3971305a4bd50 (commit)

- Log -----------------------------------------------------------------
commit 17e630f7dcb8f8a46361f5a09a872a280449ac33
Author: Stas Boukarev <stassats@...>
Date:   Sun Dec 16 21:10:08 2012 +0400

    Warn about misconfigured locale.
    
    Check the return value of setlocale(3) and inform about values of
    relevant environment variables.
    Fixes lp#727625
---
 NEWS                  |    1 +
 src/runtime/runtime.c |   48 ++++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 47 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index b7953e8..81a6e6e 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,6 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.1.2:
+  * enhancement: warnings about bad locale settings, LANG, LC_CTYPE, etc.
   * bug fix: fasls are now once again directly executable (on platforms
     supporting shebang lines, with a suitably-installed sbcl).
 
diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c
index 63bc99c..7548e1c 100644
--- a/src/runtime/runtime.c
+++ b/src/runtime/runtime.c
@@ -347,6 +347,50 @@ char *saved_runtime_path = NULL;
 void pthreads_win32_init();
 #endif
 
+void print_locale_variable(const char *name)
+{
+  char *value = getenv(name);
+
+  if (value) {
+    fprintf(stderr, "\n  %s=%s", name, value);
+  }
+}
+
+void setup_locale()
+{
+  if(setlocale(LC_ALL, "") == NULL) {
+#ifndef LISP_FEATURE_WIN32
+
+    fprintf(stderr, "WARNING: Setting locale failed.\n");
+    fprintf(stderr, "  Check the following varaibles for correct values:");
+
+    if (setlocale(LC_CTYPE, "") == NULL) {
+      print_locale_variable("LC_ALL");
+      print_locale_variable("LC_CTYPE");
+      print_locale_variable("LANG");
+    }
+
+    if (setlocale(LC_MESSAGES, "") == NULL) {
+      print_locale_variable("LC_MESSAGES");
+    }
+    if (setlocale(LC_COLLATE, "") == NULL) {
+      print_locale_variable("LC_COLLATE");
+    }
+    if (setlocale(LC_MONETARY, "") == NULL) {
+      print_locale_variable("LC_MONETARY");
+    }
+    if (setlocale(LC_NUMERIC, "") == NULL) {
+      print_locale_variable("LC_NUMERIC");
+    }
+    if (setlocale(LC_TIME, "") == NULL) {
+      print_locale_variable("LC_TIME");
+    }
+    fprintf(stderr, "\n");
+
+#endif
+  }
+}
+
 
 int
 main(int argc, char *argv[], char *envp[])
@@ -379,8 +423,6 @@ main(int argc, char *argv[], char *envp[])
     interrupt_init();
     block_blockable_signals(0, 0);
 
-    setlocale(LC_ALL, "");
-
     runtime_options = NULL;
 
     /* Save the argv[0] derived runtime path in case
@@ -561,6 +603,8 @@ main(int argc, char *argv[], char *envp[])
     gc_init();
     validate();
 
+    setup_locale();
+
     /* If no core file was specified, look for one. */
     if (!core) {
         core = search_for_core();

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  219457dafac6f2df2c53c1fb7de3971305a4bd50 (commit)
      from  dea1e4258272053e8ccda1bf670d43b429878fe2 (commit)

- Log -----------------------------------------------------------------
commit 219457dafac6f2df2c53c1fb7de3971305a4bd50
Author: David Lichteblau <david@...>
Date:   Mon Nov 26 16:30:35 2012 +0100

    Remove a few :FAILS-ON test flags for Windows
---
 tests/alien.impure.lisp     |    2 +-
 tests/condition.impure.lisp |    2 +-
 tests/filesys.pure.lisp     |    2 +-
 tests/load.impure.lisp      |    2 +-
 tests/pathnames.impure.lisp |   15 +++++++--------
 5 files changed, 11 insertions(+), 12 deletions(-)

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index 70ac73b..e68278c 100644
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -296,7 +296,7 @@
     (verify (signed 16)   #x003f8042 #x-7fbe)
     (verify (signed 16)   #x003f7042 #x7042)))
 
-(with-test (:name :bug-654485 :fails-on :win32)
+(with-test (:name :bug-654485)
   ;; DEBUG 2 used to prevent let-conversion of the open-coded ALIEN-FUNCALL body,
   ;; which in turn led the dreaded %SAP-ALIEN note.
   (handler-case
diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp
index 4812ba6..2bf5976 100644
--- a/tests/condition.impure.lisp
+++ b/tests/condition.impure.lisp
@@ -96,7 +96,7 @@
 (define-condition my-stream-error-1-0-9 (stream-error) ())
 (define-condition parse-foo-error-1-0-9 (parse-error) ())
 (define-condition read-bar-error-1-0-9 (reader-error) ())
-(with-test (:name :printable-conditions :fails-on :win32)
+(with-test (:name :printable-conditions)
   (let (;; instances created initializing all the slots specified in
         ;; ANSI CL
         (parse-foo-error-1-0-9 (make-condition 'parse-foo-error-1-0-9
diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp
index ec4c35e..a08e134 100644
--- a/tests/filesys.pure.lisp
+++ b/tests/filesys.pure.lisp
@@ -107,7 +107,7 @@
 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
 ;;; never error, and NATIVE-NAMESTRING on the result will return the
 ;;; original namestring.
-(with-test (:name :random-native-namestrings :fails-on :win32)
+(with-test (:name :random-native-namestrings)
   (let ((safe-chars
          (coerce
           (cons #\Newline
diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp
index 6219374..972a609 100644
--- a/tests/load.impure.lisp
+++ b/tests/load.impure.lisp
@@ -273,7 +273,7 @@
                               (invoke-restart 'sb-fasl::object)))))
       (load-and-assert spec fasl fasl))))
 
-(with-test (:name :bug-332 :fails-on :win32)
+(with-test (:name :bug-332)
   (flet ((stimulate-sbcl ()
            (let ((filename
                   (format nil "~A/~A.lisp"
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 04720a7..e7bee8c 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -32,7 +32,7 @@
 ;;; some things SBCL-0.6.9 used not to parse correctly:
 ;;;
 ;;; SBCL used to throw an error saying there's no translation.
-(with-test (:name (:logical-pathname 1) :fails-on :win32)
+(with-test (:name (:logical-pathname 1))
   (assert (equal (namestring (translate-logical-pathname "demo0:file.lisp"))
                  "/tmp/file.lisp")))
 
@@ -49,12 +49,12 @@
                     "/tmp/**/foo.lisp"))))
 
 ;;; That should be correct:
-(with-test (:name (:logical-pathname 4) :fails-on :win32)
+(with-test (:name (:logical-pathname 4))
   (assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
                  "/tmp/foo.lisp")))
 
 ;;; Check for absolute/relative path confusion:
-(with-test (:name (:logical-pathname 5) :fails-on :win32)
+(with-test (:name (:logical-pathname 5))
   (assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
                       "tmp/rel/foo.lisp")))
   (assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
@@ -153,7 +153,7 @@
 ;;; there's some code in this section which should be attributed
 ;;; to something in the ANSI spec, but I don't know what code it is
 ;;; or what section of the specification has the related code.
-(with-test (:name (:logical-pathname 14) :fails-on :win32)
+(with-test (:name (:logical-pathname 14))
   (setf (logical-pathname-translations "test0")
         '(("**;*.*.*"              "/library/foo/**/")))
   (assert (equal (namestring (translate-logical-pathname
@@ -179,7 +179,7 @@
 ;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem
 ;;; which doesn't have versions should ignore the version slot. CMU CL
 ;;; didn't ignore this as it should, but we do.
-(with-test (:name (:logical-pathname 15) :fails-on :win32)
+(with-test (:name (:logical-pathname 15))
   (assert (equal (namestring (translate-logical-pathname
                               "test0:foo;bar;baz;mum.quux.3"))
                  "/library/foo/foo/bar/baz/mum.quux")))
@@ -535,7 +535,7 @@
   (assert (equal (make-pathname :directory '(:absolute))
                  (read-from-string "#p\"\\\\\\\\\""))))
 
-(with-test (:name :load-logical-pathname-translations :fails-on :win32)
+(with-test (:name :load-logical-pathname-translations)
   (let* ((cwd (truename "."))
          (foo (merge-pathnames "llpnt-foo.translations" cwd))
          (bar (merge-pathnames "llpnt-bar.translations" cwd))
@@ -592,8 +592,7 @@
   ;; * / :WILD
   (assert (equal (pathname-directory #p"\\*/") '(:relative "*"))))
 
-(with-test (:name :ensure-directories-exist-with-odd-d-p-d
-                  :fails-on :win32)
+(with-test (:name :ensure-directories-exist-with-odd-d-p-d)
   (let ((*default-pathname-defaults* #p"/tmp/foo"))
     (ensure-directories-exist "/")))
 

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  dea1e4258272053e8ccda1bf670d43b429878fe2 (commit)
      from  e6132565e6dc12d8ec7f05224ffb422107e3ef4e (commit)

- Log -----------------------------------------------------------------
commit dea1e4258272053e8ccda1bf670d43b429878fe2
Author: David Lichteblau <david@...>
Date:   Mon Nov 26 14:53:17 2012 +0100

    Support long file names on Windows; more CRT function avoidance
    
      - Use native namestrings of the form \\?\ and \\?\UNC\ as required.
    
      - UNC pathnames now represented using the keyword :UNC in the device.
        This aspect of the implementation is user-visible, but considered
        subject to change.
    
      - Update a few final holdouts among the file system routines which
        were still using CRT functions and replace them with native versions:
        FILE-LENGTH, QUERY-FILE-SYSTEM, DELETE-FILE, DELETE-DIRECTORY.
    
      - Sneakily include a getenv change, technically unrelated.
    
    Thanks to Anton Kovalenko.
---
 package-data-list.lisp-expr       |    2 +
 src/code/fd-stream.lisp           |   17 +++-
 src/code/filesys.lisp             |  179 +++++++++++++++----------
 src/code/pathname.lisp            |    2 +-
 src/code/win32-pathname.lisp      |   85 ++++++++----
 src/code/win32.lisp               |  268 +++++++++++++++++++++++++++++--------
 src/compiler/generic/vm-type.lisp |    2 +-
 tests/pathnames.impure.lisp       |   21 +++
 tools-for-build/grovel-headers.c  |    5 +-
 9 files changed, 424 insertions(+), 157 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 0a0efe8..8e96d24 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2901,6 +2901,8 @@ SBCL itself"
                "FLUSH-VIEW-OF-FILE"
                "FORMAT-MESSAGE"
                "GET-FILE-ATTRIBUTES"
+               "GET-FILE-SIZE-EX"
+               "GET-FILE-TYPE"
                "GET-LAST-ERROR"
                "GET-OSFHANDLE"
                "GET-VERSION-EX"
diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index f0893eb..789e962 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -2043,6 +2043,7 @@
               :expected-type 'fd-stream
               :format-control "~S is not a stream associated with a file."
               :format-arguments (list fd-stream)))
+     #!-win32
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
                                 atime mtime ctime blksize blocks)
          (sb!unix:unix-fstat (fd-stream-fd fd-stream))
@@ -2052,7 +2053,21 @@
          (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
        (if (zerop mode)
            nil
-           (truncate size (fd-stream-element-size fd-stream)))))
+           (truncate size (fd-stream-element-size fd-stream))))
+     #!+win32
+     (let* ((handle (fd-stream-fd fd-stream))
+            (element-size (fd-stream-element-size fd-stream)))
+       (multiple-value-bind (got native-size)
+           (sb!win32:get-file-size-ex handle 0)
+         (if (zerop got)
+             ;; Might be a block device, in which case we fall back to
+             ;; a non-atomic workaround:
+             (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr))
+                    (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd)))
+               (when (and here there)
+                 (sb!unix:unix-lseek handle here sb!unix:l_set)
+                 (truncate there element-size)))
+             (truncate native-size element-size)))))
     (:file-string-length
      (etypecase arg1
        (character (fd-stream-character-size fd-stream arg1))
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index b14adc8..a0bf261 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -291,27 +291,34 @@
                  (simple-file-perror note-format pathname errno)
                  (return-from query-file-system nil))))
       (let ((filename (native-namestring pathname :as-file t)))
+        #!+win32
+        (case query-for
+          ((:existence :truename)
+           (multiple-value-bind (file kind)
+               (sb!win32::native-probe-file-name filename)
+             (when (and (not file) kind)
+               (setf file filename))
+             ;; The following OR was an AND, but that breaks files like NUL,
+             ;; for which GetLongPathName succeeds yet GetFileAttributesEx
+             ;; fails to return the file kind. --DFL
+             (if (or file kind)
+                 (values
+                  (parse-native-namestring
+                   file
+                   (pathname-host pathname)
+                   (sane-default-pathname-defaults)
+                   :as-directory (eq :directory kind)))
+                 (fail "couldn't resolve ~A" filename
+                       (- (sb!win32:get-last-error))))))
+          (:write-date
+           (or (sb!win32::native-file-write-date filename)
+               (fail "couldn't query write date of ~A" filename
+                     (- (sb!win32:get-last-error))))))
+        #!-win32
         (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size
                                       atime mtime)
             (sb!unix:unix-stat filename)
-          (declare (ignore ino nlink gid rdev size atime
-                           #!+win32 uid))
-          #!+win32
-          ;; On win32, stat regards UNC pathnames and device names as
-          ;; nonexisting, so we check once more with the native API.
-          (unless existsp
-            (setf existsp
-                  (let ((handle (sb!win32:create-file
-                                 filename 0 0 nil
-                                 sb!win32:file-open-existing
-                                 0 0)))
-                    (when (/= -1 handle)
-                      (setf mode
-                            (or mode
-                                (if (logbitp 4
-                                             (sb!win32:get-file-attributes filename))
-                                    sb!unix:s-ifdir 0)))
-                      (progn (sb!win32:close-handle handle) t)))))
+          (declare (ignore ino nlink gid rdev size atime))
           (if existsp
               (case query-for
                 (:existence (nth-value
@@ -339,9 +346,7 @@
                              ;; ... but without any trailing slash.
                              :as-directory (eql (logand  mode sb!unix:s-ifmt)
                                                 sb!unix:s-ifdir))))
-                (:author
-                 #!-win32
-                 (sb!unix:uid-username uid))
+                (:author (sb!unix:uid-username uid))
                 (:write-date (+ unix-to-universal-time mtime)))
               (progn
                 ;; SBCL has for many years had a policy that a pathname
@@ -351,7 +356,6 @@
                 ;; we must distinguish cases where the symlink exists
                 ;; from ones where there's a loop in the apparent
                 ;; containing directory.
-                #!-win32
                 (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev
                                             size atime mtime)
                     (sb!unix:unix-lstat filename)
@@ -501,9 +505,12 @@ per standard Unix unlink() behaviour."
     #!+win32
     (when (streamp file)
       (close file))
-    (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
-      (unless res
-        (simple-file-perror "Couldn't delete file ~A" namestring err))))
+    (multiple-value-bind (res err)
+        #!-win32 (sb!unix:unix-unlink namestring)
+        #!+win32 (or (sb!win32::native-delete-file namestring)
+                     (values nil (- (sb!win32:get-last-error))))
+        (unless res
+          (simple-file-perror "couldn't delete ~A" namestring err))))
   t)
 
 (defun directorize-pathname (pathname)
@@ -556,18 +563,27 @@ exist or if is a file or a symbolic link."
                               :classify-symlinks nil)
                (delete-dir dir))
              (delete-dir (dir)
-               (let* ((namestring (native-namestring dir :as-file t))
-                      (res (alien-funcall (extern-alien #!-win32 "rmdir"
-                                                        #!+win32 "_rmdir"
-                                                        (function int c-string))
-                                          namestring)))
-                 (if (minusp res)
-                     (simple-file-perror "Couldn't delete directory ~A"
-                                         namestring (get-errno))
-                     dir))))
+               (let ((namestring (native-namestring dir :as-file t)))
+                 (multiple-value-bind (res errno)
+                     #!+win32
+                     (or (sb!win32::native-delete-directory namestring)
+                         (values nil (- (sb!win32:get-last-error))))
+                     #!-win32
+                     (values
+                      (not (minusp (alien-funcall
+                                    (extern-alien "rmdir"
+                                                  (function int c-string))
+                                    namestring)))
+                      (get-errno))
+                     (if res
+                         dir
+                         (simple-file-perror
+                          "Could not delete directory ~A"
+                          namestring errno))))))
       (if recursive
           (recurse physical)
           (delete-dir physical)))))
+
 
 (defun sbcl-homedir-pathname ()
   (let ((sbcl-home (posix-getenv "SBCL_HOME")))
@@ -686,7 +702,8 @@ matching filenames."
            (canonicalize-directory (directory)
              (let (pieces)
                (dolist (piece directory)
-                 (if (and pieces (member piece '(:back :up)))
+                 (cond
+                    ((and pieces (member piece '(:back :up)))
                      ;; FIXME: We should really canonicalize when we construct
                      ;; pathnames. This is just wrong.
                      (case (car pieces)
@@ -698,8 +715,17 @@ matching filenames."
                        ((:relative :up :back)
                         (push piece pieces))
                        (t
-                        (pop pieces)))
-                     (push piece pieces)))
+                        (pop pieces))))
+                    ((equal piece ".")
+                     ;; This case only really matters on Windows,
+                     ;; because on POSIX, our call site (TRUENAME via
+                     ;; QUERY-FILE-SYSTEM) only passes in pathnames from
+                     ;; realpath(3), in which /./ has been removed
+                     ;; already.  Windows, however, depends on us to
+                     ;; perform this fixup. -- DFL
+                     )
+                    (t
+                     (push piece pieces))))
                (nreverse pieces))))
     (let ((name (simplify (pathname-name pathname)))
           (type (simplify (pathname-type pathname)))
@@ -728,6 +754,10 @@ matching filenames."
             (macrolet ((,iterator ()
                          `(funcall ,',one-iter)))
               ,@body)))
+       #!+win32
+       (sb!win32::native-call-with-directory-iterator
+        #'iterate ,namestring ,errorp)
+       #!-win32
        (call-with-native-directory-iterator #'iterate ,namestring ,errorp))))
 
 (defun call-with-native-directory-iterator (function namestring errorp)
@@ -792,9 +822,7 @@ Experimental: interface subject to change."
   (let* ((fun (%coerce-callable-to-fun function))
          (as-files (eq :as-files directories))
          (physical (physicalize-pathname directory))
-         ;; Not QUERY-FILE-SYSTEM :EXISTENCE, since it doesn't work on Windows
-         ;; network shares.
-         (realname (sb!unix:unix-realpath (native-namestring physical :as-file t)))
+         (realname (query-file-system physical :existence nil))
          (canonical (if realname
                         (parse-native-namestring realname
                                                  (pathname-host physical)
@@ -809,34 +837,39 @@ Experimental: interface subject to change."
                                         :as-directory (and dirp (not as-files)))
                                        physical))))
       (with-native-directory-iterator (next dirname :errorp errorp)
-        (loop for name = (next)
-              while name
-              do (let* ((full (concatenate 'string dirname name))
-                        (kind (native-file-kind full)))
-                   (when kind
-                     (case kind
-                       (:directory
-                        (when directories
-                          (map-it name t)))
-                       (:symlink
-                        (if classify-symlinks
-                            (let* ((tmpname (merge-pathnames
-                                             (parse-native-namestring
-                                              name nil physical :as-directory nil)
-                                             physical))
-                                   (truename (query-file-system tmpname :truename nil)))
-                              (if (or (not truename)
-                                      (or (pathname-name truename) (pathname-type truename)))
-                                  (when files
-                                    (funcall fun tmpname))
-                                  (when directories
-                                    (map-it name t))))
-                            (when files
-                              (map-it name nil))))
-                       (t
-                        ;; Anything else parses as a file.
-                        (when files
-                          (map-it name nil)))))))))))
+        (loop
+          ;; provision for FindFirstFileExW-based iterator that should be used
+          ;; on Windows: file kind is known instantly there, so we'll have it
+          ;; returned by (next) soon.
+          (multiple-value-bind (name kind) (next)
+            (unless (or name kind) (return))
+            (unless kind
+              (setf kind (native-file-kind
+                          (concatenate 'string dirname name))))
+            (when kind
+              (case kind
+                (:directory
+                 (when directories
+                   (map-it name t)))
+                (:symlink
+                 (if classify-symlinks
+                     (let* ((tmpname (merge-pathnames
+                                      (parse-native-namestring
+                                       name nil physical :as-directory nil)
+                                      physical))
+                            (truename (query-file-system tmpname :truename nil)))
+                       (if (or (not truename)
+                               (or (pathname-name truename) (pathname-type truename)))
+                           (when files
+                             (funcall fun tmpname))
+                           (when directories
+                             (map-it name t))))
+                     (when files
+                       (map-it name nil))))
+                (t
+                 ;; Anything else parses as a file.
+                 (when files
+                   (map-it name nil)))))))))))
 
 ;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION
 ;;; with all DIRECTORIES that match the directory portion of PATHSPEC.
@@ -1137,15 +1170,15 @@ Experimental: interface subject to change."
              :format-control "bad place for a wild pathname"
              :pathname pathspec))
     (let* ((dir (pathname-directory pathname))
-           ;; *d-p-d* can have name and type components which would prevent
-           ;; PROBE-FILE below from working
            (*default-pathname-defaults*
-             (make-pathname :directory dir :device (pathname-device pathname))))
-      (loop for i from 1 upto (length dir)
+             (make-pathname :directory dir :device (pathname-device pathname)))
+          (dev (pathname-device pathname)))
+      (loop for i from (case dev (:unc 3) (otherwise 2))
+              upto (length dir)
             do
             (let* ((newpath (make-pathname
                              :host (pathname-host pathname)
-                             :device (pathname-device pathname)
+                             :device dev
                              :directory (subseq dir 0 i)))
                    (probed (probe-file newpath)))
               (unless (directory-pathname-p probed)
diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index bd0471f..deb6343 100644
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -75,7 +75,7 @@
 ;;; all pathname components
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (def!type pathname-component-tokens ()
-    '(member nil :unspecific :wild)))
+    '(member nil :unspecific :wild :unc)))
 
 (sb!xc:defstruct (pathname (:conc-name %pathname-)
                            (:constructor %make-pathname (host
diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 766c068..5cfa995 100644
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -11,6 +11,9 @@
 
 (in-package "SB!IMPL")
 
+(define-symbol-macro +long-file-name-prefix+ (quote "\\\\?\\"))
+(define-symbol-macro +unc-file-name-prefix+ (quote "\\\\?\\UNC"))
+
 (defun extract-device (namestr start end)
   (declare (type simple-string namestr)
            (type index start end))
@@ -21,17 +24,9 @@
                ;; "X:" style, saved as X
                (values (string (char namestr start)) (+ start 2)))
               ((and (member c0 '(#\/ #\\)) (eql c0 c1) (>= end (+ start 3)))
-               ;; "//UNC" style, saved as UNC
-               ;; FIXME: at unparsing time we tell these apart by length,
-               ;; which seems a bit lossy -- presumably one-letter UNC
-               ;; hosts can exist as well. That seems a less troublesome
-               ;; restriction than disallowing UNC hosts whose names match
-               ;; logical pathname hosts... Time will tell -- both LispWorks
-               ;; and ACL use the host component for UNC hosts, so maybe
-               ;; we will end up there as well.
-               (let ((p (or (position c0 namestr :start (+ start 3) :end end)
-                            end)))
-                 (values (subseq namestr (+ start 2) p) p)))
+               ;; "//UNC" style, saved as :UNC device, with host and share
+               ;; becoming directory components.
+               (values :unc (+ start 1)))
               (t
                (values nil start))))
       (values nil start)))
@@ -141,7 +136,17 @@
            (type index start end))
   (setf namestring (coerce namestring 'simple-string))
   (multiple-value-bind (device new-start)
-      (extract-device namestring start end)
+      (cond ((= (length +unc-file-name-prefix+)
+                (mismatch +unc-file-name-prefix+ namestring
+                          :start2 start))
+             (values :unc (+ start (length +unc-file-name-prefix+))))
+            ((= (length +long-file-name-prefix+)
+                (mismatch +long-file-name-prefix+ namestring
+                          :start2 start))
+             (extract-device namestring
+                             (+ start (length +long-file-name-prefix+))
+                             end))
+            (t (extract-device namestring start end)))
     (multiple-value-bind (absolute ranges)
         (split-at-slashes-and-backslashes namestring new-start end)
       (let* ((components (loop for ((start . end) . rest) on ranges
@@ -188,6 +193,8 @@
         (directory (pathname-directory pathname)))
     (cond ((or (null device) (eq device :unspecific))
            "")
+          ((eq device :unc)
+           (if native "\\" "/"))
           ((and (= 1 (length device)) (alpha-char-p (char device 0)))
            (concatenate 'simple-string device ":"))
           ((and (consp directory) (eq :relative (car directory)))
@@ -242,12 +249,25 @@
          (name-string (if name-present-p name ""))
          (type (pathname-type pathname))
          (type-present-p (typep type '(not (member nil :unspecific))))
-         (type-string (if type-present-p type "")))
+         (type-string (if type-present-p type ""))
+         (absolutep (and device (eql :absolute (car directory)))))
     (when name-present-p
       (setf as-file nil))
+    (when (and absolutep (member :up directory))
+      ;; employ merge-pathnames to parse :BACKs into which we turn :UPs
+      (setf directory
+            (pathname-directory
+             (merge-pathnames
+              (make-pathname :defaults pathname :directory '(:relative))
+              (make-pathname :defaults pathname
+                             :directory (substitute :back :up directory))))))
     (coerce
      (with-output-to-string (s)
-       (when device
+       (when absolutep
+         (write-string (case device
+                         (:unc +unc-file-name-prefix+)
+                         (otherwise +long-file-name-prefix+)) s))
+       (when (or (not absolutep) (not (member device '(:unc nil))))
          (write-string (unparse-win32-device pathname t) s))
        (when directory
          (ecase (pop directory)
@@ -259,22 +279,23 @@
                      (let ((where (user-homedir-namestring (second next))))
                        (if where
                            (write-string where s)
-                           (error "User homedir unknown for: ~S" (second next)))))
+                           (error "User homedir unknown for: ~S"
+                                  (second next)))))
                     (next
                      (push next directory)))
               (write-char #\\ s)))
            (:relative)))
        (loop for (piece . subdirs) on directory
-          do (typecase piece
-               ((member :up) (write-string ".." s))
-               (string (write-string piece s))
-               (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
-                         piece)))
-          if (or subdirs (stringp name))
-          do (write-char #\\ s)
-          else
-          do (unless as-file
-               (write-char #\\ s)))
+             do (typecase piece
+                  ((member :up) (write-string ".." s))
+                  (string (write-string piece s))
+                  (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+                            piece)))
+             if (or subdirs (stringp name))
+             do (write-char #\\ s)
+             else
+             do (unless as-file
+                  (write-char #\\ s)))
        (if name-present-p
            (progn
              (unless (stringp name-string) ;some kind of wild field
@@ -288,7 +309,19 @@
            (when type-present-p ;
              (error
               "type component without a name component in NATIVE-NAMESTRING: ~S"
-              type))))
+              type)))
+       (when absolutep
+         (let ((string (get-output-stream-string s)))
+           (return-from unparse-native-win32-namestring
+             (cond ((< (- 260 12) (length string))
+                    ;; KLUDGE: account for additional length of 8.3 name to make
+                    ;; directories always accessible
+                    (coerce string 'simple-string))
+                   ((eq :unc device)
+                    (replace
+                     (subseq string (1- (length +unc-file-name-prefix+)))
+                     "\\"))
+                   (t (subseq string (length +long-file-name-prefix+))))))))
      'simple-string)))
 
 ;;; FIXME.
diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index a01ac36..3bdbf58 100644
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -28,12 +28,46 @@
                    #!-sb-unicode c-string
                    #!+sb-unicode (c-string :external-format :ucs-2))
 
+(define-alien-type tchar #!-sb-unicode char
+                         #!+sb-unicode (unsigned 16))
+
 (defconstant default-environment-length 1024)
 
 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
 ;;; to a pointer.
 (defconstant invalid-handle -1)
 
+(defconstant file-attribute-readonly #x1)
+(defconstant file-attribute-hidden #x2)
+(defconstant file-attribute-system #x4)
+(defconstant file-attribute-directory #x10)
+(defconstant file-attribute-archive #x20)
+(defconstant file-attribute-device #x40)
+(defconstant file-attribute-normal #x80)
+(defconstant file-attribute-temporary #x100)
+(defconstant file-attribute-sparse #x200)
+(defconstant file-attribute-reparse-point #x400)
+(defconstant file-attribute-reparse-compressed #x800)
+(defconstant file-attribute-reparse-offline #x1000)
+(defconstant file-attribute-not-content-indexed #x2000)
+(defconstant file-attribute-encrypted #x4000)
+
+(defconstant file-flag-overlapped #x40000000)
+(defconstant file-flag-sequential-scan #x8000000)
+
+;; Possible results of GetFileType.
+(defconstant file-type-disk 1)
+(defconstant file-type-char 2)
+(defconstant file-type-pipe 3)
+(defconstant file-type-remote 4)
+(defconstant file-type-unknown 0)
+
+(defconstant invalid-file-attributes (mod -1 (ash 1 32)))
+
+;;;; File Type Introspection by handle
+(define-alien-routine ("GetFileType" get-file-type) dword
+  (handle handle))
+
 ;;;; Error Handling
 
 ;;; Retrieve the calling thread's last-error code value.  The
@@ -428,6 +462,17 @@
 (defmacro make-system-buffer (x)
  `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
 
+(defmacro with-handle ((var initform
+                            &key (close-operator 'close-handle))
+                            &body body)
+  `(without-interrupts
+       (block nil
+         (let ((,var ,initform))
+           (unwind-protect
+                (with-local-interrupts
+                    ,@body)
+             (,close-operator ,var))))))
+
 (define-alien-type pathname-buffer
     (array char #.(ash (1+ max_path) #!+sb-unicode 1 #!-sb-unicode 0)))
 
@@ -435,6 +480,9 @@
     #!+sb-unicode (array char 65536)
     #!-sb-unicode pathname-buffer)
 
+(defmacro decode-system-string (alien)
+  `(cast (cast ,alien (* char)) system-string))
+
 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
 ;;; macros in this file, are only used in this file, and could be
 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
@@ -475,12 +523,16 @@
 
 (defun get-last-error-message (err)
   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
-  (with-alien ((amsg (* char)))
-    (syscall (("FormatMessage" t)
-              dword dword dword dword dword (* (* char)) dword dword)
-             (cast-and-free amsg :free-function local-free)
-             (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
-             0 err 0 (addr amsg) 0 0)))
+  (let ((message
+         (with-alien ((amsg (* char)))
+           (syscall (("FormatMessage" t)
+                     dword dword dword dword dword (* (* char)) dword dword)
+                    (cast-and-free amsg :free-function local-free)
+                    (logior FORMAT_MESSAGE_ALLOCATE_BUFFER
+                            FORMAT_MESSAGE_FROM_SYSTEM
+                            FORMAT_MESSAGE_MAX_WIDTH_MASK)
+                    0 err 0 (addr amsg) 0 0))))
+    (and message (string-right-trim '(#\Space) message))))
 
 (defmacro win32-error (func-name &optional err)
   `(let ((err-code ,(or err `(get-last-error))))
@@ -492,35 +544,39 @@
 
 (defun get-folder-namestring (csidl)
   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
-  (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
+  (with-alien ((apath pathname-buffer))
     (syscall (("SHGetFolderPath" t) int handle int handle dword (* char))
-             (concatenate 'string (cast-and-free apath) "\\")
-             0 csidl 0 0 apath)))
+             (concatenate 'string (decode-system-string apath) "\\")
+             0 csidl 0 0 (cast apath (* char)))))
 
 (defun get-folder-pathname (csidl)
   (parse-native-namestring (get-folder-namestring csidl)))
 
 (defun sb!unix:posix-getcwd ()
-  (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
+  (with-alien ((apath pathname-buffer))
     (with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char))
-      (let ((ret (alien-funcall afunc (1+ max_path) apath)))
+      (let ((ret (alien-funcall afunc (1+ max_path) (cast apath (* char)))))
         (when (zerop ret)
           (win32-error "GetCurrentDirectory"))
-        (when (> ret (1+ max_path))
-          (free-alien apath)
-          (setf apath (make-system-buffer ret))
-          (alien-funcall afunc ret apath))
-        (cast-and-free apath)))))
+        (if (> ret (1+ max_path))
+            (with-alien ((apath (* char) (make-system-buffer ret)))
+              (alien-funcall afunc ret apath)
+              (cast-and-free apath))
+            (decode-system-string apath))))))
 
 (defun sb!unix:unix-mkdir (name mode)
   (declare (type sb!unix:unix-pathname name)
            (type sb!unix:unix-file-mode mode)
            (ignore mode))
-  (void-syscall* (("CreateDirectory" t) system-string dword) name 0))
+  (syscall (("CreateDirectory" t) lispbool system-string (* t))
+           (values result (if result 0 (- (get-last-error))))
+           name nil))
 
 (defun sb!unix:unix-rename (name1 name2)
   (declare (type sb!unix:unix-pathname name1 name2))
-  (void-syscall* (("MoveFile" t) system-string system-string) name1 name2))
+  (syscall (("MoveFile" t) lispbool system-string system-string)
+           (values result (if result 0 (- (get-last-error))))
+           name1 name2))
 
 (defun sb!unix::posix-getenv (name)
   (declare (type simple-string name))
@@ -556,6 +612,15 @@
 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
 (define-alien-type FILETIME (sb!alien:unsigned 64))
 
+;; FILETIME definition above is almost correct (on little-endian systems),
+;; except for the wrong alignment if used in another structure: the real
+;; definition is a struct of two dwords.
+;; Let's define FILETIME-MEMBER for that purpose; it will be useful with
+;; GetFileAttributesEx and FindFirstFileExW.
+
+(define-alien-type FILETIME-MEMBER
+    (struct nil (low dword) (high dword)))
+
 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
                               &body forms)
   `(with-alien ((,creation-time filetime)
@@ -620,6 +685,9 @@
 ;;            (addr epoch)
 ;;            (addr filetime)))
 (defconstant +unix-epoch-filetime+ 116444736000000000)
+(defconstant +filetime-unit+ (* 100ns-per-internal-time-unit
+                                internal-time-units-per-second))
+(defconstant +common-lisp-epoch-filetime-seconds+ 9435484800)
 
 #!-sb-fluid
 (declaim (inline get-time-of-day))
@@ -635,15 +703,134 @@ UNIX epoch: January 1st 1970."
                (values sec (floor 100ns 10)))
              (addr system-time))))
 
+;; Data for FindFirstFileExW and GetFileAttributesEx
+(define-alien-type find-data
+    (struct nil
+            (attributes dword)
+            (ctime filetime-member)
+            (atime filetime-member)
+            (mtime filetime-member)
+            (size-low dword)
+            (size-high dword)
+            (reserved0 dword)
+            (reserved1 dword)
+            (long-name (array tchar #.max_path))
+            (short-name (array tchar 14))))
+
+(define-alien-type file-attributes
+    (struct nil
+            (attributes dword)
+            (ctime filetime-member)
+            (atime filetime-member)
+            (mtime filetime-member)
+            (size-low dword)
+            (size-high dword)))
+
+(define-alien-routine ("FindClose" find-close) lispbool
+  (handle handle))
+
+(defun attribute-file-kind (dword)
+  (if (logtest file-attribute-directory dword)
+      :directory :file))
+
+(defun native-file-write-date (native-namestring)
+  "Return file write date, represented as CL universal time."
+  (with-alien ((file-attributes file-attributes))
+    (syscall (("GetFileAttributesEx" t) lispbool
+              system-string int file-attributes)
+             (and result
+                  (- (floor (deref (cast (slot file-attributes 'mtime)
+                                         (* filetime)))
+                            +filetime-unit+)
+                     +common-lisp-epoch-filetime-seconds+))
+             native-namestring 0 file-attributes)))
+
+(defun native-probe-file-name (native-namestring)
+  "Return truename \(using GetLongPathName\) as primary value,
+File kind as secondary.
+
+Unless kind is false, null truename shouldn't be interpreted as error or file
+absense."
+  (with-alien ((file-attributes file-attributes)
+               (buffer long-pathname-buffer))
+    (syscall (("GetFileAttributesEx" t) lispbool
+              system-string int file-attributes)
+             (values
+              (syscall (("GetLongPathName" t) dword
+                        system-string long-pathname-buffer dword)
+                       (and (plusp result) (decode-system-string buffer))
+                       native-namestring buffer 32768)
+              (and result
+                   (attribute-file-kind
+                    (slot file-attributes 'attributes))))
+             native-namestring 0 file-attributes)))
+
+(defun native-delete-file (native-namestring)
+  (syscall (("DeleteFile" t) lispbool system-string)
+           result native-namestring))
+
+(defun native-delete-directory (native-namestring)
+  (syscall (("RemoveDirectory" t) lispbool system-string)
+           result native-namestring))
+
+(defun native-call-with-directory-iterator (function namestring errorp)
+  (declare (type (or null string) namestring)
+           (function function))
+  (when namestring
+    (with-alien ((find-data find-data))
+      (with-handle (handle (syscall (("FindFirstFile" t) handle
+                                     system-string find-data)
+                                    (if (eql result invalid-handle)
+                                        (if errorp
+                                            (win32-error "FindFirstFile")
+                                            (return))
+                                        result)
+                                    (concatenate 'string
+                                                 namestring "*.*")
+                                    find-data)
+                    :close-operator find-close)
+        (let ((more t))
+          (dx-flet ((one-iter ()
+                      (tagbody
+                       :next
+                         (when more
+                           (let ((name (decode-system-string
+                                        (slot find-data 'long-name)))
+                                 (attributes (slot find-data 'attributes)))
+                             (setf more
+                                   (syscall (("FindNextFile" t) lispbool
+                                             handle find-data) result
+                                             handle find-data))
+                             (cond ((equal name ".") (go :next))
+                                   ((equal name "..") (go :next))
+                                   (t
+                                    (return-from one-iter
+                                      (values name
+                                              (attribute-file-kind
+                                               attributes))))))))))
+            (funcall function #'one-iter)))))))
+
 ;; SETENV
 ;; The SetEnvironmentVariable function sets the contents of the specified
 ;; environment variable for the current process.
 ;;
 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
 (defun setenv (name value)
-  (declare (type simple-string name value))
-  (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
-                 name value))
+  (declare (type (or null simple-string) value))
+  (if value
+      (void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
+                     name value)
+      (void-syscall* (("SetEnvironmentVariable" t) system-string int-ptr)
+                     name 0)))
+
+;; Let SETENV be an accessor for POSIX-GETENV.
+;;
+;; DFL: Merged this function because it seems useful to me.  But
+;; shouldn't we then define it on actual POSIX, too?
+(defun (setf sb!unix::posix-getenv) (new-value name)
+  (if (setenv name new-value)
+      new-value
+      (posix-getenv name)))
 
 (defmacro c-sizeof (s)
   "translate alien size (in bits) to c-size (in bytes)"
@@ -719,7 +906,7 @@ UNIX epoch: January 1st 1970."
   (protection dword)
   (maximum-size-high dword)
   (maximum-size-low dword)
-  (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+  (name system-string))
 
 (define-alien-routine ("MapViewOfFile" map-view-of-file)
     system-area-pointer
@@ -749,13 +936,14 @@ UNIX epoch: January 1st 1970."
 (defconstant access-generic-execute #x20000000)
 (defconstant access-generic-all #x10000000)
 (defconstant access-file-append-data #x4)
+(defconstant access-delete #x00010000)
 
 ;; share modes
 (defconstant file-share-delete #x04)
 (defconstant file-share-read #x01)
 (defconstant file-share-write #x02)
 
-;; CreateFile (the real file-opening workhorse)
+;; CreateFile (the real file-opening workhorse).
 (define-alien-routine (#!+sb-unicode "CreateFileW"
                        #!-sb-unicode "CreateFileA"
                        create-file)
@@ -768,36 +956,10 @@ UNIX epoch: January 1st 1970."
   (flags-and-attributes dword)
   (template-file handle))
 
-(defconstant file-attribute-readonly #x1)
-(defconstant file-attribute-hidden #x2)
-(defconstant file-attribute-system #x4)
-(defconstant file-attribute-directory #x10)
-(defconstant file-attribute-archive #x20)
-(defconstant file-attribute-device #x40)
-(defconstant file-attribute-normal #x80)
-(defconstant file-attribute-temporary #x100)
-(defconstant file-attribute-sparse #x200)
-(defconstant file-attribute-reparse-point #x400)
-(defconstant file-attribute-reparse-compressed #x800)
-(defconstant file-attribute-reparse-offline #x1000)
-(defconstant file-attribute-not-content-indexed #x2000)
-(defconstant file-attribute-encrypted #x4000)
-
-(defconstant file-flag-overlapped #x40000000)
-(defconstant file-flag-sequential-scan #x8000000)
-
-;; Possible results of GetFileType.
-(defconstant file-type-disk 1)
-(defconstant file-type-char 2)
-(defconstant file-type-pipe 3)
-(defconstant file-type-remote 4)
-(defconstant file-type-unknown 0)
-
-(defconstant invalid-file-attributes (mod -1 (ash 1 32)))
-
-;;;; File Type Introspection by handle
-(define-alien-routine ("GetFileType" get-file-type) dword
-  (handle handle))
+;; GetFileSizeEx doesn't work with block devices :[
+(define-alien-routine ("GetFileSizeEx" get-file-size-ex)
+    bool
+  (handle handle) (file-size (signed 64) :in-out))
 
 ;; GetFileAttribute is like a tiny subset of fstat(),
 ;; enough to distinguish directories from anything else.
diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index 997aa8e..618de2b 100644
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -61,7 +61,7 @@
 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
 (sb!xc:deftype pathname-host () '(or sb!impl::host null))
 (sb!xc:deftype pathname-device ()
-  '(or simple-string (member nil :unspecific)))
+  '(or simple-string (member nil :unspecific :unc)))
 (sb!xc:deftype pathname-directory () 'list)
 (sb!xc:deftype pathname-name ()
   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index e05e8db..04720a7 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -597,4 +597,25 @@
   (let ((*default-pathname-defaults* #p"/tmp/foo"))
     (ensure-directories-exist "/")))
 
+(with-test (:name :long-file-name :skipped-on '(not :win32))
+  (let* ((x '("hint--if-you-are-having-trouble-deleting-this-test-directory"
+              "use-the-7zip-file-manager"))
+         (base (truename
+                (directory-namestring (or *load-pathname* *compile-pathname*))))
+         (shallow (make-pathname :directory `(:relative ,(car x))))
+         (shallow (merge-pathnames shallow base))
+         (deep (make-pathname
+                :directory `(:relative ,@(loop repeat 10 appending x))))
+         (deep (merge-pathnames deep base))
+         (native (sb-ext:native-namestring deep)))
+    (assert (> (length native) 260))
+    (assert (eql 3 (mismatch "\\\\?" native)))
+    (assert (not (probe-file shallow)))
+    (unwind-protect
+         (progn
+           (ensure-directories-exist deep)
+           (assert (probe-file deep)))
+      (sb-ext:delete-directory shallow :recursive t))
+    (assert (not (probe-file shallow)))))
+
 ;;;; success
diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c
index 125f884..e1e0166 100644
--- a/tools-for-build/grovel-headers.c
+++ b/tools-for-build/grovel-headers.c
@@ -186,8 +186,9 @@ main(int argc, char *argv[])
 
     printf(";;; FormatMessage\n");
 
-    defconstant ("FORMAT_MESSAGE_ALLOCATE_BUFFER", FORMAT_MESSAGE_ALLOCATE_BUFFER);
-    defconstant ("FORMAT_MESSAGE_FROM_SYSTEM", FORMAT_MESSAGE_FROM_SYSTEM);
+    defconstant("FORMAT_MESSAGE_ALLOCATE_BUFFER", FORMAT_MESSAGE_ALLOCATE_BUFFER);
+    defconstant("FORMAT_MESSAGE_FROM_SYSTEM", FORMAT_MESSAGE_FROM_SYSTEM);
+    defconstant("FORMAT_MESSAGE_MAX_WIDTH_MASK", FORMAT_MESSAGE_MAX_WIDTH_MASK);
 
     printf(";;; Errors\n");
 

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL

The branch "master" has been updated in SBCL:
       via  e6132565e6dc12d8ec7f05224ffb422107e3ef4e (commit)
      from  359c7f002c22bdfebffb87e2a4c23bab7da4b393 (commit)

- Log -----------------------------------------------------------------
commit e6132565e6dc12d8ec7f05224ffb422107e3ef4e
Author: David Lichteblau <david@...>
Date:   Mon Nov 26 17:38:34 2012 +0100

    More Windows Installer tweaks
    
      - look for version 3.7 or 3.5 automatically
    
      - make the "start menu" shortcut optional
    
      - suppress "test-output" directory
---
 make-windows-installer.sh |    9 ++++++++-
 tools-for-build/wxs.lisp  |    5 +++--
 2 files changed, 11 insertions(+), 3 deletions(-)

diff --git a/make-windows-installer.sh b/make-windows-installer.sh
index a7e4886..3b10048 100644
--- a/make-windows-installer.sh
+++ b/make-windows-installer.sh
@@ -9,7 +9,14 @@
 # provided with absolutely no warranty. See the COPYING and CREDITS
 # files for more information.
 
-WIX_PATH="${WIX_PATH:-$PROGRAMFILES\Windows Installer XML v3.5\bin}"
+if test -n "$WIX_PATH"; then
+    :
+elif test -d "$PROGRAMFILES/WiX Toolset v3.7"; then
+    WIX_PATH="$PROGRAMFILES/WiX Toolset v3.7/bin"
+elif test -d "$PROGRAMFILES/Windows Installer XML v3.5"; then
+    WIX_PATH="$PROGRAMFILES/Windows Installer XML v3.5/bin"
+fi
+echo "using $WIX_PATH"
 
 . ./sbcl-pwd.sh
 sbcl_pwd
diff --git a/tools-for-build/wxs.lisp b/tools-for-build/wxs.lisp
index baf16a1..bcc928e 100644
--- a/tools-for-build/wxs.lisp
+++ b/tools-for-build/wxs.lisp
@@ -117,7 +117,7 @@
 (defun file-id (pathname)
   (id (format nil "File_~A" (enough-namestring pathname *sbcl-source-root*))))
 
-(defparameter *ignored-directories* '("CVS" ".svn"))
+(defparameter *ignored-directories* '("CVS" ".svn" "test-output"))
 
 (defparameter *pathname-type-abbrevs*
   '(("lisp" . "lsp")
@@ -275,9 +275,10 @@
                   "ConfigurableDirectory" "INSTALLDIR"
                   "Level" 1)
        ("ComponentRef" ("Id" "SBCL_Base"))
-       ("ComponentRef" ("Id" "SBCL_Shortcut"))
        ("Feature" ("Id" "Contrib" "Level" 1 "Title" "Contributed Modules")
                   ,@(ref-all-components))
+       ("Feature" ("Id" "Shortcut" "Level" 1 "Title" "Add Start Menu Shortcut")
+                  ("ComponentRef" ("Id" "SBCL_Shortcut")))
        ("Feature" ("Id" "SetPath" "Level" 1 "Title" "Set Environment Variable: PATH")
                   ("ComponentRef" ("Id" "SBCL_SetPATH")))
        ;; SetHome is still enabled by default (level 1), because SBCL

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL