Changeset 13112 for release


Ignore:
Timestamp:
Oct 28, 2009, 11:56:56 PM (10 years ago)
Author:
rme
Message:

Trunk changes through r13111.

Location:
release/1.4/source
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • release/1.4/source/level-1/l1-processes.lisp

    r13075 r13112  
    639639    (with-standard-abort-handling "Exit Lisp"
    640640      (prepare-to-quit)
    641       (fresh-line *stdout*)
    642       (finish-output *stdout*))
     641      ;; We may have abruptly terminated a thread
     642      ;; which owned the output lock on *STDOUT*.
     643      ;; Don't block waiting on that lock if so.
     644      (let* ((s *stdout*)
     645             (lock (ioblock-outbuf-lock (basic-stream-ioblock s)))
     646             (locked (make-lock-acquisition)))
     647        (declare (dynamic-extent locked))
     648        (when (or (null lock) (%try-recursive-lock-object lock locked))
     649          (unwind-protect
     650               (progn
     651                 (fresh-line s)
     652                 (finish-output s)))
     653          (when (lock-acquisition.status locked) (release-lock lock)))))
    643654    (%set-toplevel thunk)
    644655    (toplevel)))
  • release/1.4/source/level-1/l1-symhash.lisp

    r13075 r13112  
    631631                        (cerror "Do nothing" 'no-such-package :package package)
    632632                        (return-from delete-package nil)))))
    633   (unless (memq package %all-packages%)
    634     (return-from delete-package nil))
     633  (with-package-list-read-lock
     634    (unless (memq package %all-packages%)
     635      (return-from delete-package nil)))
    635636  (when (pkg.used-by package)
    636637    (cerror "unuse ~S" 'package-is-used-by :package package
     
    641642    (unuse-package (car (pkg.used package)) package))
    642643  (setf (pkg.shadowed package) nil)
    643   (setq %all-packages% (nremove package %all-packages%))
     644  (with-package-list-write-lock
     645    (setq %all-packages% (nremove package %all-packages%)))
    644646  (dolist (n (pkg.names package))
    645647    (let* ((ref (register-package-ref n)))
  • release/1.4/source/level-1/l1-typesys.lisp

    r13075 r13112  
    14871487  (logand (sxhash spec) type-cache-mask))
    14881488
     1489
    14891490(let* ((type-cache-specs (make-array type-cache-size))
    14901491       (type-cache-ctypes (make-array type-cache-size))
     
    14921493       (hits 0)
    14931494       (ncleared 0)
    1494        (locked nil))
     1495       (locked nil)
     1496       (lock (make-lock)))
    14951497 
    14961498  (defun clear-type-cache ()
    1497     (%init-misc 0 type-cache-specs)
    1498     (%init-misc 0 type-cache-ctypes)
    1499     (incf ncleared)
     1499    (with-lock-grabbed (lock)
     1500      (%init-misc 0 type-cache-specs)
     1501      (%init-misc 0 type-cache-ctypes)
     1502      (incf ncleared))
    15001503    nil)
    15011504
     
    15041507      (let* ((class-ctype (%class.ctype spec)))
    15051508        (or (class-ctype-translation class-ctype) class-ctype))
    1506       (if locked
    1507         (or (values-specifier-type-internal spec env)
    1508             (make-unknown-ctype :specifier spec))
    1509         (unwind-protect
    1510           (progn
    1511             (setq locked t)
    1512             (if (or (symbolp spec)
    1513                     (and (consp spec)
    1514                          (symbolp (car spec))
    1515                          ;; hashing scheme uses equal, so only use when equivalent to eql
    1516                          (not (and (eq (car spec) 'member)
    1517                                    (some (lambda (x)
    1518                                            (typep x '(or cons string bit-vector pathname)))
    1519                                          (cdr spec))))))
    1520               (let* ((idx (hash-type-specifier spec)))
    1521                 (incf probes)
    1522                 (if (equal (svref type-cache-specs idx) spec)
    1523                   (progn
    1524                     (incf hits)
    1525                     (svref type-cache-ctypes idx))
    1526                   (let* ((ctype (values-specifier-type-internal spec env)))
    1527                     (if ctype
    1528                       (progn
    1529                         (when (cacheable-ctype-p ctype)
    1530                           (setf (svref type-cache-specs idx) (copy-tree spec)       ; in case it was stack-consed
    1531                                 (svref type-cache-ctypes idx) ctype))
    1532                         ctype)
    1533                       (make-unknown-ctype :specifier spec)))))
    1534               (values-specifier-type-internal spec env)))
    1535           (setq locked nil)))))
     1509      (handler-case
     1510          (with-lock-grabbed (lock)
     1511            (if locked
     1512              (or (values-specifier-type-internal spec env)
     1513                  (make-unknown-ctype :specifier spec))
     1514              (unwind-protect
     1515                   (progn
     1516                     (setq locked t)
     1517                     (if (or (symbolp spec)
     1518                             (and (consp spec)
     1519                                  (symbolp (car spec))
     1520                                  ;; hashing scheme uses equal, so only use when equivalent to eql
     1521                                  (not (and (eq (car spec) 'member)
     1522                                            (some (lambda (x)
     1523                                                    (typep x '(or cons string bit-vector pathname)))
     1524                                                  (cdr spec))))))
     1525                       (let* ((idx (hash-type-specifier spec)))
     1526                         (incf probes)
     1527                         (if (equal (svref type-cache-specs idx) spec)
     1528                           (progn
     1529                             (incf hits)
     1530                             (svref type-cache-ctypes idx))
     1531                           (let* ((ctype (values-specifier-type-internal spec env)))
     1532                             (if ctype
     1533                               (progn
     1534                                 (when (cacheable-ctype-p ctype)
     1535                                   (setf (svref type-cache-specs idx) (copy-tree spec) ; in case it was stack-consed
     1536                                         (svref type-cache-ctypes idx) ctype))
     1537                                 ctype)
     1538                               (make-unknown-ctype :specifier spec)))))
     1539                       (values-specifier-type-internal spec env)))
     1540                (setq locked nil))))
     1541        (error (condition) (error condition)))))
    15361542 
    15371543  (defun type-cache-hit-rate ()
     
    15431549  (defun lock-type-cache ()
    15441550    (setq locked t)))
    1545 
    15461551                   
    15471552
  • release/1.4/source/level-1/linux-files.lisp

    r13075 r13112  
    10261026    watched-fds
    10271027    watched-streams
     1028    external-format
    10281029    )
    10291030
     
    10421043                                    &key direction (element-type 'character)
    10431044                                    (sharing :private)
     1045                                    external-format
    10441046                                    &allow-other-keys)
    10451047    (etypecase object
     
    10661068                                    :sharing sharing
    10671069                                    :basic t
     1070                                    :encoding (external-format-character-encoding external-format)
     1071                                    :line-termination (external-format-line-termination external-format)
    10681072                                    :auto-close t)
    10691073                    (cons read-pipe close-in-parent)
     
    10771081                                    :basic t
    10781082                                    :sharing sharing
     1083                                    :encoding (external-format-character-encoding external-format)
     1084                                    :line-termination (external-format-line-termination external-format)
    10791085                                    :auto-close t)
    10801086                    (cons write-pipe close-in-parent)
     
    10911097                   (cons fd close-in-parent)
    10921098                   (cons fd close-on-error)))))
     1099      #||
     1100      ;; What's an FD-STREAM ?
    10931101      (fd-stream
    10941102       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
     
    10971105                 (cons fd close-in-parent)
    10981106                 (cons fd close-on-error))))
     1107      ||#
    10991108      (stream
    11001109       (ecase direction
     
    11051114                (%errno-disp fd))
    11061115              (#_unlink template)
    1107               (loop
    1108                 (multiple-value-bind (line no-newline)
    1109                     (read-line object nil nil)
    1110                   (unless line
    1111                     (return))
    1112                   (let* ((len (length line)))
    1113                     (%stack-block ((buf (1+ len)))
    1114                       (%cstr-pointer line buf)
    1115                       (fd-write fd buf len)
    1116                       (if no-newline
    1117                         (return))
    1118                       (setf (%get-byte buf) (char-code #\newline))
    1119                       (fd-write fd buf 1)))))
     1116              (let* ((out (make-fd-stream (fd-dup fd)
     1117                                          :direction :output
     1118                                          :encoding (external-format-character-encoding external-format)
     1119                                          :line-termination (external-format-line-termination external-format))))
     1120                (loop
     1121                  (multiple-value-bind (line no-newline)
     1122                      (read-line object nil nil)
     1123                    (unless line
     1124                      (return))
     1125                    (if no-newline
     1126                      (write-string line out)
     1127                      (write-line line out))))
     1128                (close out))
    11201129              (fd-lseek fd 0 #$SEEK_SET)
    11211130              (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
     
    11671176           (changed)
    11681177           (maxfd 0)
    1169            (pairs (pairlis in-fds out-streams)))
     1178           (external-format (external-process-external-format p))
     1179           (encoding (external-format-character-encoding external-format))
     1180           (line-termination (external-format-line-termination external-format))
     1181           (pairs (pairlis
     1182                   (mapcar (lambda (fd)
     1183                             (cons fd
     1184                                   (make-fd-stream fd
     1185                                                   :direction :input
     1186                                                   :sharing :private
     1187                                                   :encoding encoding
     1188                                                   :line-termination line-termination)))
     1189                                     in-fds) out-streams)))
    11701190      (%stack-block ((in-fd-set *fd-set-size*))
    11711191        (rlet ((tv #>timeval))
     
    11811201              (setq maxfd 0)
    11821202              (dolist (p pairs)
    1183                 (let* ((fd (car p)))
     1203                (let* ((fd (caar p)))
    11841204                  (when (> fd maxfd)
    11851205                    (setq maxfd fd))
     
    11901210                       0)
    11911211                (dolist (p pairs)
    1192                   (let* ((in-fd (car p))
     1212                  (let* ((in-fd (caar p))
     1213                         (in-stream (cdar p))
    11931214                         (out-stream (cdr p)))
    11941215                    (when (fd-is-set in-fd in-fd-set)
    1195                       (%stack-block ((buf 1024))
    1196                         (let* ((n (fd-read in-fd buf 1024)))
    1197                           (declare (fixnum n))
    1198                           (if (<= n 0)
    1199                             (without-interrupts
    1200                               (decf (car token))
    1201                               (fd-close in-fd)
    1202                               (setf (car p) nil changed t))
    1203                             (let* ((string (make-string 1024)))
    1204                               (declare (dynamic-extent string))
    1205                               (%str-from-ptr buf n string)
    1206                               (write-sequence string out-stream :end n))))))))))
     1216                      (let* ((buf (make-string 1024))
     1217                             (n (ignore-errors (read-sequence buf in-stream))))
     1218                        (declare (dynamic-extent buf))
     1219                        (if (or (null n) (eql n 0))
     1220                          (without-interrupts
     1221                           (decf (car token))
     1222                           (close in-stream)
     1223                           (setf (car p) nil changed t))
     1224                          (write-sequence buf out-stream :end n))))))))
    12071225            (let* ((statusflags (check-pid (external-process-pid p)
    12081226                                           (logior
     
    12901308                              env
    12911309                              (sharing :private)
     1310                              (external-format `(:character-encoding ,*terminal-character-encoding-name*))
    12921311                              (silently-ignore-catastrophic-failures
    12931312                               *silently-ignore-catastrophic-failure-in-run-program*))
     
    13191338             :error nil
    13201339             :token token
    1321              :status-hook status-hook)))
     1340             :status-hook status-hook
     1341             :external-format (setq external-format (normalize-external-format t external-format)))))
    13221342      (unwind-protect
    13231343           (progn
     
    13261346                                   :if-does-not-exist if-input-does-not-exist
    13271347                                   :element-type element-type
    1328                                    :sharing sharing))
     1348                                   :sharing sharing
     1349                                   :external-format external-format))
    13291350             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    13301351               (get-descriptor-for output proc close-in-parent close-on-error
     
    13321353                                   :if-exists if-output-exists
    13331354                                   :element-type element-type
    1334                                    :sharing sharing))
     1355                                   :sharing sharing
     1356                                   :external-format external-format))
    13351357             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    13361358               (if (eq error :output)
     
    13401362                                     :if-exists if-error-exists
    13411363                                     :sharing sharing
    1342                                      :element-type element-type)))
     1364                                     :element-type element-type
     1365                                     :external-format external-format)))
    13431366             (setf (external-process-input proc) in-stream
    13441367                   (external-process-output proc) out-stream
     
    14461469                                    direction (element-type 'character)
    14471470                                    (sharing :private)
     1471                                    external-format
    14481472                                    &allow-other-keys)
    14491473    (etypecase object
     
    14701494                                    :basic t
    14711495                                    :sharing sharing
     1496                                    :encoding (external-format-character-encoding external-format)
     1497                                    :line-termination (external-format-line-termination external-format)
    14721498                                    :auto-close t)
    14731499                    (cons read-pipe close-in-parent)
     
    14811507                                    :basic t
    14821508                                    :sharing sharing
     1509                                    :encoding (external-format-character-encoding external-format)
     1510                                    :line-termination (external-format-line-termination external-format)
    14831511                                    :auto-close t)
    14841512                    (cons write-pipe close-in-parent)
     
    14951523                   (cons fd close-in-parent)
    14961524                   (cons fd close-on-error)))))
    1497       (fd-stream
    1498        (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
    1499          (values fd
    1500                  nil
    1501                  (cons fd close-in-parent)
    1502                  (cons fd close-on-error))))
    15031525      (stream
    15041526       (ecase direction
     
    15081530            (if (< fd 0)
    15091531              (%errno-disp fd))
    1510             (loop
    1511               (multiple-value-bind (line no-newline)
    1512                   (read-line object nil nil)
    1513                 (unless line
    1514                   (return))
    1515                 (let* ((len (length line)))
    1516                   (%stack-block ((buf (1+ len)))
    1517                     (%cstr-pointer line buf)
    1518                     (fd-write fd buf len)
    1519                     (if no-newline
    1520                       (return))
    1521                     (setf (%get-byte buf) (char-code #\newline))
    1522                     (fd-write fd buf 1)))))
     1532            (let* ((out (make-fd-stream (fd-dup fd)
     1533                                        :direction :output
     1534                                        :encoding (external-format-character-encoding external-format)
     1535                                        :line-termination (external-format-line-termination external-format))))           
     1536              (loop
     1537                (multiple-value-bind (line no-newline)
     1538                    (read-line object nil nil)
     1539                  (unless line
     1540                    (return))
     1541                  (if no-newline
     1542                    (write-string line out)
     1543                    (write-line line out))
     1544                  ))
     1545              (close out))
    15231546            (fd-lseek fd 0 #$SEEK_SET)
    15241547            (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     
    15501573    watched-fds
    15511574    watched-streams
     1575    external-format
    15521576    )
    15531577
     
    15711595                              status-hook (element-type 'character)
    15721596                              (sharing :private)
     1597                              (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf))
    15731598                              env)
    15741599    "Invoke an external program as an OS subprocess of lisp."
     
    15951620             :error nil
    15961621             :token token
     1622             :external-format (setq external-format (normalize-external-format t external-format))
    15971623             :status-hook status-hook)))
    15981624      (unwind-protect
     
    16021628                                   :if-does-not-exist if-input-does-not-exist
    16031629                                   :sharing sharing
    1604                                    :element-type element-type))
     1630                                   :element-type element-type
     1631                                   :external-format external-format))
    16051632             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    16061633               (get-descriptor-for output proc close-in-parent close-on-error
     
    16081635                                   :if-exists if-output-exists
    16091636                                   :sharing sharing
    1610                                    :element-type element-type))
     1637                                   :element-type element-type
     1638                                   :external-format external-format))
    16111639             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    16121640               (if (eq error :output)
     
    16161644                                     :if-exists if-error-exists
    16171645                                     :sharing sharing
    1618                                      :element-type element-type)))
     1646                                     :element-type element-type
     1647                                     :external-format external-format)))
    16191648             (setf (external-process-input proc) in-stream
    16201649                   (external-process-output proc) out-stream
     
    17431772           (terminated)
    17441773           (changed)
    1745            (pairs (pairlis in-fds out-streams))
     1774           (pairs (pairlis (mapcar (lambda (fd)
     1775                                     (cons fd
     1776                                           (make-fd-stream fd
     1777                                                           :direction :input
     1778                                                           :sharing :private
     1779                                                           :encoding encoding
     1780                                                           :line-termination line-termination)))
     1781                                   in-fds)
     1782                           out-streams))
    17461783           )
    17471784      (loop
     
    17681805           (return)))
    17691806        (dolist (p pairs)
    1770           (let* ((in-fd (car p))
     1807          (let* ((in-fd (caar p))
     1808                 (in-stream (cdar p))
    17711809                 (out-stream (cdr p)))
    17721810            (when (or terminated (data-available-on-pipe-p in-fd))
    1773               (%stack-block ((buf 1024))
    1774                 (let* ((n (fd-read in-fd buf 1024)))
    1775                   (declare (fixnum n))
    1776                   (if (<= n 0)
     1811              (let* ((buf (make-string 1024)))
     1812                (declare (dynamic-extent buf))
     1813                (let* ((n (ignore-errors (read-sequence buf in-stream))))
     1814                  (if (or (null n) (eql n 0))
    17771815                    (progn
    17781816                      (without-interrupts
     
    17801818                       (fd-close in-fd)
    17811819                       (setf (car p) nil changed t)))
    1782 
    1783                     (let* ((string (make-string n))
    1784                            (m 0))
    1785                       (declare (dynamic-extent string)
    1786                                (fixnum m))
    1787                       ;; Not quite right: we really want to map
    1788                       ;; CRLF to #\Newline, but stripping #\Return
    1789                       ;; is usually the same thing and easier.
    1790                       (dotimes (i n)
    1791                         (let* ((code (%get-unsigned-byte buf i)))
    1792                           (unless (eql code (char-code #\Return))
    1793                             (setf (schar string m) (code-char code))
    1794                             (incf m))))
    1795                       (write-sequence string out-stream :end m)
    1796                       (force-output out-stream))))))))
     1820                    (progn
     1821                      (write-sequence buf out-stream :end n)
     1822                      (force-output out-stream))))))))
    17971823        (unless terminated
    17981824          (setq terminated (eql (#_WaitForSingleObjectEx
  • release/1.4/source/lib/dumplisp.lisp

    r13075 r13112  
    5757                    ;; startup code.
    5858                    (if (and (eql (typecode o) target::subtag-instance)
    59                              (typep o 'buffered-stream-mixin))
     59                             (typep o 'buffered-stream-mixin)
     60                             (slot-boundp o 'ioblock))
    6061                      (let ((s (slot-value o 'ioblock)))
    6162                        (when (and (typep s 'ioblock)
  • release/1.4/source/lib/setf.lisp

    r13075 r13112  
    900900      (multiple-value-bind (dummies vals newval setter getter)
    901901          (get-setf-expansion place env)
    902         (setf all-dummies (append all-dummies dummies))
    903         (setf all-vals (append all-vals vals))
    904         (setf newvals (append newvals newval))
     902        (setf all-dummies (append all-dummies dummies (cdr newval)))
     903        (setf all-vals (append all-vals vals (mapcar (constantly nil) (cdr newval))))
     904        (setf newvals (append newvals (list (car newval))))
    905905        (push setter setters)
    906906        (push getter getters)))
  • release/1.4/source/lisp-kernel/thread_manager.c

    r13075 r13112  
    106106       !((where < (pc) (ts->high)) &&
    107107         (where >= (pc) (ts->low))))) {
     108
     109    target->interrupt_pending = (1LL << (nbits_in_word - 1LL));
     110
     111#if 0
    108112    /* If the thread's in a blocking syscall, it'd be nice to
    109113       get it out of that state here. */
    110114    GetThreadIOPendingFlag(hthread,&io_pending);
    111     target->interrupt_pending = (1LL << (nbits_in_word - 1LL));
    112115    if (io_pending) {
    113116      pending_io * pending = (pending_io *) (target->pending_io_info);
     
    120123      }
    121124    }
     125#endif
    122126    if (pCancelSynchronousIo) {
    123127      pCancelSynchronousIo(hthread);
  • release/1.4/source/scripts/ccl

    r13075 r13112  
    22#
    33# Change the definition of CCL_DEFAULT_DIRECTORY below to refer to
    4 # your Clozure CL installation directory. 
     4# your OpenMCL installation directory. 
    55# Any definition of CCL_DEFAULT_DIRECTORY already present in the environment
    66# takes precedence over definitions made below.
    77
    8 probe()
    9 {
    10     if [ -e "$1"  -a  -e "$1/scripts/ccl" ]; then
    11         CCL_DEFAULT_DIRECTORY="$1"
    12     fi
    13 }
    14 
    15 if [ -z "$CCL_DEFAULT_DIRECTORY"  -a  -n "`which readlink`" ]; then
    16     dir="`readlink $0`"
    17     probe "${dir%/scripts/ccl}"
    18 fi
    19 
    208if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then
    21     probe "`pwd`"
    22 fi
    23 
    24 if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then
    25     probe "/usr/local/src/ccl"
    26 fi
    27 
    28 if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then
    29     echo "Can't find CCL directory.  Please edit $0 or"
    30     echo "set the environment variable CCL_DEFAULT_DIRECTORY"
    31     echo "and try again."
    32     exit 1
     9  CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl
    3310fi
    3411
     
    4017DD=${CCL_DEFAULT_DIRECTORY}
    4118
    42 # If you don't want to guess the name of the Clozure CL kernel on
     19# If you don't want to guess the name of the OpenMCL kernel on
    4320# every invocation (or if you want to use a kernel with a
    4421# non-default name), you might want to uncomment and change
  • release/1.4/source/scripts/ccl64

    r13075 r13112  
    22#
    33# Change the definition of CCL_DEFAULT_DIRECTORY below to refer to
    4 # your Clozure CL installation directory. 
     4# your OpenMCL installation directory. 
    55# Any definition of CCL_DEFAULT_DIRECTORY already present in the environment
    66# takes precedence over definitions made below.
    77
    8 probe()
    9 {
    10     if [ -e "$1"  -a  -e "$1/scripts/ccl64" ]; then
    11         CCL_DEFAULT_DIRECTORY="$1"
    12     fi
    13 }
    14 
    15 if [ -z "$CCL_DEFAULT_DIRECTORY"  -a  -n "`which readlink`" ]; then
    16     dir="`readlink $0`"
    17     probe "${dir%/scripts/ccl64}"
    18 fi
    19 
    208if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then
    21     probe "`pwd`"
    22 fi
    23 
    24 if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then
    25     probe "/usr/local/src/ccl"
    26 fi
    27 
    28 if [ -z "$CCL_DEFAULT_DIRECTORY" ]; then
    29     echo "Can't find CCL directory.  Please edit $0 or"
    30     echo "set the environment variable CCL_DEFAULT_DIRECTORY"
    31     echo "and try again."
    32     exit 1
     9  CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl
    3310fi
    3411
     
    3815DD=${CCL_DEFAULT_DIRECTORY}
    3916
    40 # If you don't want to guess the name of the Clozure CL kernel on
     17# If you don't want to guess the name of the OpenMCL kernel on
    4118# every invocation (or if you want to use a kernel with a
    4219# non-default name), you might want to uncomment and change
Note: See TracChangeset for help on using the changeset viewer.