Changeset 15606


Ignore:
Timestamp:
Jan 28, 2013, 4:34:15 PM (6 years ago)
Author:
gb
Message:

This is a work-in-progress; there will need to be new binaries
and similar changes for other architectures.

compiler/nx2.lisp: do late constant-folding on comparisons. (This depends

on being able to use operators for T and NIL in the backend; since backends
don't necessarily support that, check first.)

compiler/optimizers.lisp: bind temporaries for 3-arg numeric comparisons.

compiler/vinsn.lisp: do dead-code elimination at the vinsn level. Because

of the way that "aligned labels" work on x86, introduce an :align vinsn
attribute. Add/change some utilities for finding next/previous vinsn, etc.

compiler/X86/x862.lisp: Handle operators for T/NIL. Peephole optimize

things like (if (let ...)) where the LET returns a constant value and
we need to discard some words from the stack.

compiler/X86/X8632/x8632-arch.lisp:
compiler/X86/X8664/x8664-arch.lisp: Bump image version

compiler/X86/X8632/x8632-vinsns.lisp:
compiler/X86/X8664/x8664-vinsns.lisp: EMIT-ALIGNED-LABEL has :align

attribute

level-0/l0-hash.lisp: Don't assume that GC maintains weak-deletions; do

assume that it maintains count/deleted-count, so lock-based code adjusts
those slots atomically.

level-0/l0-misc.lisp: We don't want to use futexes (at least not instead

of spinlocks.)

level-0/X86/x86-misc.lisp: %ATOMIC-INCF-NODE needs to pause while spinning.

(Note that a locked ADD may be faster on x86, but wouldn't return a
meaningful value and some callers expect it to.)

level-1/l1-clos-boot.lisp: no more DESTRUCTURE-STATE.
level-1/l1-files.lisp: indentation change
level-1/l1-utils.lisp: no more DESTRUCTURE-STATE.
level-1/linux-files.lisp: UNSETENV

lib/hash.lisp: no need to %NORMALIZE-HASH-TABLE-COUNT.
lib/macros.lisp: no more DESTRUCTURE-STATE.

library/lispequ.lisp: no more DESTRUCTURE-STATE.

lisp-kernel/gc-common.c: decrement count when removing weak key from

hash vector; increment deleted-count if not lock-free.

lisp-kernel/x86-constants32.h:
lisp-kernel/x86-constants64.h: bump current, max image versions

lisp-kernel/linuxx8632/Makefile:
lisp-kernel/linuxx8664/Makefile: don't define USE_FUTEX.

Location:
trunk/source
Files:
24 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/X8632/x8632-arch.lisp

    r15582 r15606  
    13401340(defconstant fasl-max-version #x60)
    13411341(defconstant fasl-min-version #x60)
    1342 (defparameter *image-abi-version* 1038)
     1342(defparameter *image-abi-version* 1039)
    13431343
    13441344(provide "X8632-ARCH")
  • trunk/source/compiler/X86/X8632/x8632-vinsns.lisp

    r15564 r15606  
    16271627  (pushl (:%l temp)))
    16281628
    1629 (define-x8632-vinsn emit-aligned-label (()
    1630                                         ((label :label)))
     1629(define-x8632-vinsn (emit-aligned-label :align) (()
     1630                                                ((label :label)))
    16311631  ;; We don't care about label.
    16321632  ;; We just want the label following this stuff to be tra-tagged.
  • trunk/source/compiler/X86/X8664/x8664-arch.lisp

    r15582 r15606  
    13551355(defconstant fasl-max-version #x60)
    13561356(defconstant fasl-min-version #x60)
    1357 (defparameter *image-abi-version* 1038)
     1357(defparameter *image-abi-version* 1039)
    13581358
    13591359(provide "X8664-ARCH")
  • trunk/source/compiler/X86/X8664/x8664-vinsns.lisp

    r15564 r15606  
    17831783
    17841784;; ????
    1785 (define-x8664-vinsn emit-aligned-label (()
    1786                                         ((label :label)))
     1785(define-x8664-vinsn (emit-aligned-label :align) (()
     1786                                                 ((label :label)))
    17871787  (:align 3)
    17881788  (:long (:^ label)))
  • trunk/source/compiler/X86/x862.lisp

    r15564 r15606  
    13811381      (if (nx-t form)
    13821382        (x862-t seg vreg xfer)
    1383         (let* ((fn (x862-acode-operator-function form)) ;; also typechecks
     1383        (let* ((fn (x862-acode-operator-function form));; also typechecks
    13841384               (op (acode-operator form)))
    13851385          (if (and (null vreg)
     
    57025702              ;; case of a null vd can certainly avoid it; the check
    57035703              ;; of numundo is to keep $acc boxed in case of nthrow.
    5704               (x862-form  seg (if (or vreg (not (%izerop numundo))) *x862-arg-z*) nil body)
    5705               (x862-unwind-set seg xfer old-stack)
    5706               (when vreg (<- *x862-arg-z*))
    5707               (^))))))))
     5704              (let* ((so-far (dll-header-last seg))
     5705                     (handled-crf nil))
     5706                (declare (ignorable so-far))
     5707                (x862-form  seg (if (or vreg (not (%izerop numundo))) *x862-arg-z*) nil body)
     5708                (when (and (backend-crf-p vreg)
     5709                           (eql 0 numundo))
     5710                  (let* ((last-vinsn (last-vinsn seg so-far))
     5711                         (unconditional (and last-vinsn (eq last-vinsn (last-vinsn-unless-label seg))))
     5712                         (vinsn-name (and last-vinsn (vinsn-template-name (vinsn-template last-vinsn))))
     5713                         (constant-valued (member vinsn-name
     5714                                                  '(load-nil load-t lri lriu ref-constant))))
     5715                    (when constant-valued
     5716                      (let* ((targetlabel (if (eq vinsn-name 'load-nil) (x862-cd-false xfer) (x862-cd-true xfer))))
     5717                        (and (> targetlabel 0)
     5718                             (> $backend-return targetlabel)
     5719                             (let* ((diff (- *x862-vstack* (nth-value 2 (x862-decode-stack old-stack))))
     5720                                    (adjust (remove-dll-node (! vstack-discard (ash diff (- *x862-target-fixnum-shift*)))))
     5721                                    (jump (remove-dll-node (! jump (aref *backend-labels* targetlabel)))))
     5722                               (insert-dll-node-after adjust last-vinsn)
     5723                               (insert-dll-node-after jump adjust)
     5724                               (remove-dll-node last-vinsn)
     5725                               (setq handled-crf unconditional)))))))
     5726                (unless handled-crf
     5727                  (x862-unwind-set seg xfer old-stack)
     5728                  (when vreg (<- *x862-arg-z*))
     5729                  (^))))))))))
    57085730
    57095731
     
    67816803          bits)))))
    67826804
     6805(defx862 x862-nil nil (seg vreg xfer)
     6806  (x862-nil seg vreg xfer))
     6807
     6808(defx862 x862-t t (seg vreg xfer)
     6809  (x862-t seg vreg xfer))
    67836810
    67846811(defx862 x862-progn progn (seg vreg xfer forms)
     
    77977824                        (if true-is-goto 0 falselabel)
    77987825                        (if true-is-goto xfer (x862-cd-merge xfer falselabel)))))
    7799                  testform) 
     7826                 testform)
    78007827                (if true-is-goto
    78017828                  (x862-unreachable-store)
  • trunk/source/compiler/nx2.lisp

    r15517 r15606  
    832832(defun acode-optimize-numcmp (seg vreg xfer cc num1 num2 trust-decls &optional (result-type 'boolean))
    833833  (declare (ignorable result-type))
    834   (cond ((and (acode-form-typep num1 *nx-target-fixnum-type* trust-decls)
    835               (acode-form-typep num2 *nx-target-fixnum-type* trust-decls))
    836          (backend-use-operator (%nx1-operator %i<>) seg vreg xfer cc num1 num2)
    837          t)
    838         ((and (acode-form-typep num1 *nx-target-natural-type* trust-decls)
    839               (acode-form-typep num2 *nx-target-natural-type* trust-decls))
    840          (backend-use-operator (%nx1-operator %natural<>) seg vreg xfer cc num1 num2)
    841          t)
    842         ((and (acode-form-typep num1 'double-float trust-decls)
    843               (acode-form-typep num2 'double-float trust-decls))
    844          (backend-use-operator (%nx1-operator double-float-compare) seg vreg xfer cc num1 num2)
    845          t)
    846         ((and (acode-form-typep num1 'single-float trust-decls)
    847               (acode-form-typep num2 'single-float trust-decls))
    848          (backend-use-operator (%nx1-operator short-float-compare) seg vreg xfer cc num1 num2)
    849          t)))
     834  (let* ((c1 (acode-real-constant-p num1))
     835         (c2 (acode-real-constant-p num2)))
     836
     837    (if (and c1 c2 (svref (backend-p2-dispatch *target-backend*) (logand (%nx1-operator nil) operator-id-mask)))
     838      (let* ((name (ecase (cadr cc)
     839                     (:eq '=-2)
     840                     (:ne '/=-2)
     841                     (:lt '<-2)
     842                     (:le '<=-2)
     843                     (:gt '>-2)
     844                     (:ge '>=-2))))
     845        (backend-use-operator (if (funcall name c1 c2) (%nx1-operator t) (%nx1-operator nil)) seg vreg xfer)
     846        t)
     847      (cond ((and (acode-form-typep num1 *nx-target-fixnum-type* trust-decls)
     848                  (acode-form-typep num2 *nx-target-fixnum-type* trust-decls))
     849             (backend-use-operator (%nx1-operator %i<>) seg vreg xfer cc num1 num2)
     850             t)
     851            ((and (acode-form-typep num1 *nx-target-natural-type* trust-decls)
     852                  (acode-form-typep num2 *nx-target-natural-type* trust-decls))
     853             (backend-use-operator (%nx1-operator %natural<>) seg vreg xfer cc num1 num2)
     854             t)
     855            ((and (acode-form-typep num1 'double-float trust-decls)
     856                  (acode-form-typep num2 'double-float trust-decls))
     857             (backend-use-operator (%nx1-operator double-float-compare) seg vreg xfer cc num1 num2)
     858             t)
     859            ((and (acode-form-typep num1 'single-float trust-decls)
     860                  (acode-form-typep num2 'single-float trust-decls))
     861             (backend-use-operator (%nx1-operator short-float-compare) seg vreg xfer cc num1 num2)
     862             t)))))
    850863
    851864(defun acode-optimize-minus1 (seg vreg xfer form trust-decls &optional (result-type 'number))
  • trunk/source/compiler/optimizers.lisp

    r15575 r15606  
    278278        whole
    279279        (let* ((n2 (car more))
    280                (n (gensym)))
    281           (if (and (typep n0 'real) (typep n1 'real))
    282             (let* ((result (funcall binary-name n0 n1)))
    283               (if result
    284                 `(,binary-name ,n1 ,n2)
    285                 `(progn ,n2 nil)))
    286             `(let* ((,n ,n0))
    287               (if (,binary-name ,n (setq ,n ,n1))
    288                 (,binary-name ,n ,n2)
    289                 (progn ,n2 nil))))))
     280               (a (gensym))
     281               (b (gensym))
     282               (c (gensym)))
     283          `(let* ((,a ,n0)
     284                  (,b ,n1)
     285                  (,c ,n2))
     286            (if (,binary-name ,a ,b) (,binary-name ,b ,c)))))
    290287      (if (not n1-p)
    291288        `(require-type ,n0 'real)
  • trunk/source/compiler/vinsn.lisp

    r15076 r15606  
    242242        (when annotation
    243243          (format stream " ||~a|| " annotation))))))
    244  
     244
     245(eval-when (:compile-toplevel :load-toplevel :execute)
    245246(defparameter *known-vinsn-attributes*
    246247  '(
     
    248249    :branch                             ; a conditional branch
    249250    :call                               ; a jump that returns
    250     :funcall                            ; A full function call, assumed to bash all volatile registers
     251    :align                              ; aligns FOLLOWING label
    251252    :subprim-call                       ; A subprimitive call; bashes some volatile registers
    252253    :jumpLR                             ; Jumps to the LR, possibly stopping off at a function along the way.
     
    274275    :predicatable                       ; all instructions can be predicated, no instructions set or test condition codes.
    275276    :sets-lr                            ; uses the link register, if there is one.
    276     ))
     277    )))
    277278
    278279(defparameter *nvp-max* 10 "size of *vinsn-varparts* freelist elements")
     
    583584      (return t))))
    584585
    585 (defun last-vinsn (seg)
     586(defun last-vinsn (seg &optional (after seg))
    586587  ;; Try to find something that isn't a SOURCE-NOTE.  Go ahead.  I dare you.
    587588  (do* ((element (dll-header-last seg) (dll-node-pred element)))
    588        ((eq element seg))               ;told ya!
     589       ((eq element after))               ;told ya!
    589590    (when (typep element 'vinsn)
    590591      (return element))))
     
    767768            (push ref (vinsn-label-refs target))))))))
    768769
     770(defparameter *nx-do-dead-code-elimination* t)
     771
     772(defun eliminate-dead-code (header)
     773  (when *nx-do-dead-code-elimination*
     774    (let* ((eliding nil)
     775           (won nil))
     776      (do-dll-nodes (element header won)
     777        ;; If a label, leave it.
     778        (etypecase element
     779          (vinsn-label
     780           (when (typep (vinsn-label-id element) 'fixnum)
     781             (if (vinsn-label-refs element)
     782               (setq eliding nil))))
     783          (vinsn
     784           (when (vinsn-attribute-p element :align)
     785             (let* ((next (vinsn-succ element)))
     786               (when (and (typep next 'vinsn-label)
     787                          (typep (vinsn-label-id next) 'fixnum)
     788                          (not (null (vinsn-label-refs next))))
     789                 (setq eliding nil))))
     790           (cond (eliding
     791                    (setq won t)
     792                    (let* ((operands (vinsn-variable-parts element)))
     793                      (dotimes (i (length operands) (elide-vinsn element))
     794                        (let* ((op (svref operands i)))
     795                          (when (typep op 'vinsn-label)
     796                            (setf (vinsn-label-refs op)
     797                                  (delete element (vinsn-label-refs op))))))))
     798                   (t (setq eliding (vinsn-attribute-p element :jump))))))))))
     799         
     800
    769801(defun optimize-vinsns (header)
    770802  ;; Delete unreferenced labels that the compiler might have emitted.
     
    790822    (maximize-jumps header)
    791823    (delete-unreferenced-labels labels)
    792     (normalize-vinsns header)
     824    ;;(normalize-vinsns header)
     825    (eliminate-dead-code header)
    793826  ))
    794827
     
    843876    v))
    844877
     878       
     879(defun last-vinsn-unless-label (seg)
     880  ;; Look at the last element(s) of seg.  If a vinsn-note,
     881  ;; keep looking.  If a vinsn, return it; if a vinsn-label,
     882  ;; return nil
     883  (do* ((element (dll-header-last seg) (dll-node-pred element)))
     884       ((eq element seg))
     885    (etypecase element
     886      (vinsn (return element))
     887      (vinsn-label (if (typep (vinsn-label-id element) 'fixnum)
     888                     (return nil))))))
     889       
     890
     891
     892
    845893;;; This generally only gives a meaningful result if pass 2 of the
    846894;;; compiler has been compiled in the current session.
  • trunk/source/level-0/X86/x86-misc.lisp

    r15500 r15606  
    754754  (lock)
    755755  (cmpxchgq (% arg_z) (@ (% node) (% imm1)))
    756   (jne @again)
     756  (je @win)
     757  (pause)
     758  (jmp @again)
     759  @win
    757760  (single-value-return))
    758761
  • trunk/source/level-0/l0-hash.lisp

    r15601 r15606  
    406406  (istruct-typep hash 'hash-table))
    407407
    408 (defun %normalize-hash-table-count (hash)
    409   (let* ((vector (nhash.vector hash))
    410          (weak-deletions-count (nhash.vector.weak-deletions-count vector)))
    411     (declare (fixnum weak-deletions-count))
    412     (unless (eql 0 weak-deletions-count)
    413       (setf (nhash.vector.weak-deletions-count vector) 0)
    414       ;; lock-free hash tables don't maintain deleted-count, since would need to
    415       ;; lock and it's not worth it.
    416       (unless (hash-lock-free-p hash)
    417         (let ((deleted-count (the fixnum
    418                                (+ (the fixnum (nhash.vector.deleted-count vector))
    419                                   weak-deletions-count)))
    420               (count (the fixnum (- (the fixnum (nhash.vector.count vector)) weak-deletions-count))))
    421           (setf (nhash.vector.deleted-count vector) deleted-count
    422                 (nhash.vector.count vector) count))))))
    423408
    424409
     
    599584    ;; We don't try to maintain a running total, so just count.
    600585    (return-from hash-table-count (lock-free-count-entries hash)))
    601   (%normalize-hash-table-count hash)
    602586  (the fixnum (nhash.vector.count (nhash.vector hash))))
    603587
     
    940924                 (atomic-decf (nhash.grow-threshold hash))
    941925                 (when (set-hash-key-conditional vector-index vector free-hash-marker key)
    942                    ;; %needs-rehashing-p is not equite enough in the track_keys case, since gc cannot
     926                   ;; %needs-rehashing-p is not quite enough in the track_keys case, since gc cannot
    943927                   ;; track this key until it's actually added to the table.  Check now.
    944928                   (if (and (%ilogbitp $nhash_track_keys_bit (nhash.vector.flags vector))
     
    10581042               (setf (%svref vector vidx) deleted-hash-key-marker)
    10591043               (setf (%svref vector (the fixnum (1+ vidx))) nil))
    1060              (incf (the fixnum (nhash.vector.deleted-count vector)))
    1061              (decf (the fixnum (nhash.vector.count vector)))
     1044             (atomic-incf (the fixnum (nhash.vector.deleted-count vector)))
     1045             (atomic-decf (the fixnum (nhash.vector.count vector)))
    10621046             (setq foundp t))
    10631047           (let* ((vector-index (funcall (nhash.find hash) hash key)))
     
    10701054                     (nhash.vector.cache-value vector) nil)
    10711055               ;; Update the count
    1072                (incf (the fixnum (nhash.vector.deleted-count vector)))
    1073                (decf (the fixnum (nhash.vector.count vector)))
     1056               (atomic-incf (the fixnum (nhash.vector.deleted-count vector)))
     1057               (atomic-decf (the fixnum (nhash.vector.count vector)))
    10741058               ;; Delete the value from the table.
    10751059               (setf (%svref vector vector-index) deleted-hash-key-marker
     
    11081092             (nhash.vector.finalization-alist vector) nil
    11091093             (nhash.vector.free-alist vector) nil
    1110              (nhash.vector.weak-deletions-count vector) 0
    11111094             (nhash.vector.deleted-count vector) 0
    11121095             (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
     
    11491132                     (%set-hash-table-vector-key vector vector-index key)
    11501133                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
    1151                      (incf (the fixnum (nhash.vector.count vector)))
     1134                     (atomic-incf (nhash.vector.count vector))
    11521135                     ;; Adjust deleted-count
    1153                      (when (> 0 (the fixnum
    1154                                   (decf (the fixnum
    1155                                           (nhash.vector.deleted-count vector)))))
    1156                        (%normalize-hash-table-count hash)))
     1136                     (atomic-decf (nhash.vector.deleted-count vector)))
    11571137                    ((eq old-value free-hash-marker)
    11581138                     (when (eql 0 (nhash.grow-threshold hash))
     
    11631143                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
    11641144                     (decf (the fixnum (nhash.grow-threshold hash)))
    1165                      (incf (the fixnum (nhash.vector.count vector))))
     1145                     (atomic-incf (the fixnum (nhash.vector.count vector))))
    11661146                    (t
    11671147                     ;; Key was already there, update value.
     
    11881168          (return count))))))
    11891169
    1190 
    1191 
    1192 
    1193 
    1194      
    1195 
    11961170(defun grow-hash-table (hash)
    11971171  (unless (typep hash 'hash-table)
     
    12111185(defun %grow-hash-table (hash)
    12121186  (block grow-hash-table
    1213     (%normalize-hash-table-count hash)
    12141187    (let* ((old-vector (nhash.vector hash))
    12151188           (old-size (nhash.vector.count old-vector))
     
    12361209                    weak-flags (logand flags $nhash_weak_flags_mask))
    12371210              (setf (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
    1238               (%normalize-hash-table-count hash)
    12391211              (when (%grow-hash-table-in-place-p hash)
    12401212                (setf (nhash.vector.flags old-vector) flags)
     
    15631535            (when (or deleted (eq key free-hash-marker))
    15641536              (if deleted  ; one less deleted entry
    1565                 (let ((count (1- (nhash.vector.deleted-count vector))))
    1566                   (declare (fixnum count))
    1567                   (setf (nhash.vector.deleted-count vector) count)
    1568                   (if (< count 0)
    1569                     (let ((wdc (nhash.vector.weak-deletions-count vector)))
    1570                       (setf (nhash.vector.weak-deletions-count vector) 0)
    1571                       (incf (nhash.vector.deleted-count vector) wdc)
    1572                       (decf (nhash.vector.count vector) wdc)))
     1537                (progn
     1538                  (atomic-decf  (nhash.vector.deleted-count vector))
    15731539                  (incf (nhash.grow-threshold hash))
    15741540                  ;; Change deleted to free
     
    15971563                                  (setq deleted (eq newkey deleted-hash-key-marker)))
    15981564                          (when deleted
    1599                             (let ((count (1- (nhash.vector.deleted-count vector))))
    1600                               (declare (fixnum count))
    1601                               (setf (nhash.vector.deleted-count vector) count)
    1602                               (if (< count 0)
    1603                                 (let ((wdc (nhash.vector.weak-deletions-count vector)))
    1604                                   (setf (nhash.vector.weak-deletions-count vector) 0)
    1605                                   (incf (nhash.vector.deleted-count vector) wdc)
    1606                                   (decf (nhash.vector.count vector) wdc)))
    1607                               (incf (nhash.grow-threshold hash))))
     1565                            (atomic-decf (nhash.vector.deleted-count vector))
     1566                            (incf (nhash.grow-threshold hash)))
    16081567                          (return))
    16091568                        (when (eq key newkey)
    16101569                          (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
    16111570                                  key hash value newvalue index found-index)                       
    1612                           (decf (nhash.vector.count vector))
     1571                          (atomic-decf (nhash.vector.count vector))
    16131572                          (incf (nhash.grow-threshold hash))
    16141573                          (return))
     
    19631922          (nhash.vector.free-alist vector) nil
    19641923          (nhash.vector.finalization-alist vector) nil
    1965           (nhash.vector.weak-deletions-count vector) 0
    19661924          (nhash.vector.hash vector) nil
    19671925          (nhash.vector.deleted-count vector) 0
  • trunk/source/level-0/l0-misc.lisp

    r15526 r15606  
    2020
    2121;;; Bootstrapping for futexes
    22 #+(and linux-target (or x86-target arm-target))
     22#+(and linux-target no (or x86-target arm-target))
    2323(eval-when (:compile-toplevel :execute)
    2424  (pushnew :futex *features*))
  • trunk/source/level-1/l1-clos-boot.lisp

    r15559 r15606  
    18841884  (make-istruct-class 'logical-pathname (find-class 'pathname))
    18851885
    1886   (make-istruct-class 'destructure-state *istruct-class*)
    18871886 
    18881887  (defstatic *base-char-class* (alias-class 'base-char *character-class*))
  • trunk/source/level-1/l1-files.lisp

    r15602 r15606  
    138138    (multiple-value-bind (sstr start end) (get-sstring name)
    139139      (declare (simple-string sstr) (fixnum start end))
    140         (let* ((ncopy 0)
    141                (skipped nil)
    142                (quote-next nil))
    143           (declare (fixnum ncopy))
    144           (do* ((i start (1+ i)))
    145                ((= i end))
    146             (declare (fixnum i))
    147             (let* ((ch (schar sstr i)))
    148               (cond ((or quote-next (not (eq ch esc)))
    149                      (incf ncopy)
    150                      (setq quote-next nil))
    151                     ((eq ch esc) (setq skipped t) (setq quote-next t)))))
    152           (if (not skipped)
    153             name
    154             (let ((result (make-string ncopy))
    155                   (dest 0))
    156               (declare (fixnum dest))
    157               (setq quote-next nil)
    158               (do* ((i start (1+ i)))
    159                    ((= i end) result)
    160                 (declare (fixnum i))
    161                 (let* ((ch (schar sstr i)))
    162                   (cond ((or quote-next (not (eq ch esc)))
    163                          (setf (schar result dest) ch)
    164                          (incf dest)
    165                          (setq quote-next nil))
    166                         ((eq ch esc) (setq quote-next t)))))))))))
     140      (let* ((ncopy 0)
     141             (skipped nil)
     142             (quote-next nil))
     143        (declare (fixnum ncopy))
     144        (do* ((i start (1+ i)))
     145             ((= i end))
     146          (declare (fixnum i))
     147          (let* ((ch (schar sstr i)))
     148            (cond ((or quote-next (not (eq ch esc)))
     149                   (incf ncopy)
     150                   (setq quote-next nil))
     151                  ((eq ch esc) (setq skipped t) (setq quote-next t)))))
     152        (if (not skipped)
     153          name
     154          (let ((result (make-string ncopy))
     155                (dest 0))
     156            (declare (fixnum dest))
     157            (setq quote-next nil)
     158            (do* ((i start (1+ i)))
     159                 ((= i end) result)
     160              (declare (fixnum i))
     161              (let* ((ch (schar sstr i)))
     162                (cond ((or quote-next (not (eq ch esc)))
     163                       (setf (schar result dest) ch)
     164                       (incf dest)
     165                       (setq quote-next nil))
     166                      ((eq ch esc) (setq quote-next t)))))))))))
    167167
    168168(defun translated-namestring (path)
  • trunk/source/level-1/l1-utils.lisp

    r15526 r15606  
    135135
    136136
    137 (defun %pop-required-arg-ptr (ptr)
    138   (if (atom (destructure-state.current ptr))
    139     (signal-program-error "Required arguments in ~s don't match lambda list ~s."
    140            (destructure-state.whole ptr) (destructure-state.lambda ptr))
    141     (pop (destructure-state.current ptr))))
    142 
    143 (defun %default-optional-value (ptr &optional default)
    144   (let* ((tail (destructure-state.current ptr)))
    145     (if tail
    146       (if (atom tail)
    147         (signal-program-error "Optional arguments in ~s don't match lambda list ~s."
    148                (destructure-state.whole ptr) (destructure-state.lambda ptr))
    149         (pop (destructure-state.current ptr)))
    150       default)))
    151 
    152 (defun %check-extra-arguments (ptr)
    153   (when (destructure-state.current ptr)
    154     (signal-program-error "Extra arguments in ~s don't match lambda list ~s."
    155                           (destructure-state.whole ptr) (destructure-state.lambda ptr))))
     137
    156138
    157139(defun %keyword-present-p (keys keyword)
  • trunk/source/level-1/linux-files.lisp

    r15494 r15606  
    354354    (#_setenv ckey cvalue (if overwrite 1 0)))
    355355  #+windows-target
    356   (with-cstrs ((pair (format nil "~a=~a" key value)))
     356  (with-cstrs ((pair (concatenate 'string key "=" value)))
    357357    (#__putenv pair))
    358358  )
     359
     360(defun unsetenv (key)
     361  #-windows-target
     362  (with-cstrs ((ckey key))
     363    (#_unsetenv key))
     364  #+windows-target
     365  (with-cstrs ((ckey (concatenate 'string "=")))
     366    (#__putenv ckey)))
    359367
    360368#-windows-target                        ; Windows "impersonation" crap ?
  • trunk/source/lib/hash.lisp

    r14379 r15606  
    248248(defmethod make-load-form ((hash hash-table) &optional env)
    249249  (declare (ignore env))
    250   (%normalize-hash-table-count hash)
    251250  (let ((keytransF (nhash.keytransF hash))
    252251        (compareF (nhash.compareF hash))
  • trunk/source/lib/macros.lisp

    r15540 r15606  
    10161016      ,@(when decls `((declare ,@decls)))
    10171017      ,@body)))
    1018 
    1019 (defmacro make-destructure-state (tail whole lambda)
    1020   `(%istruct 'destructure-state ,tail ,whole ,lambda))
    10211018
    10221019
  • trunk/source/library/lispequ.lisp

    r14972 r15606  
    121121(defconstant $sym_fbit_fold_subforms (+ 8 $sym_bit_global))
    122122
    123 (def-accessors () %svref
    124   nil                                   ;'destructure-state
    125   destructure-state.current
    126   destructure-state.whole
    127   destructure-state.lambda
    128   )
     123
    129124
    130125;Lfun bits.
    131126;Assumed to be a fixnum, so if you ever assign a bit number > 28,
    132 ;change lfun-bits and its callers.
     127;change lfun-bits and its callers.  Do the same if you change the
     128;number of bits in a fixnum, too.  Ignore other sign.
    133129(defconstant $lfbits-nonnullenv-bit 0)
    134130(defconstant $lfbits-keys-bit 1)
  • trunk/source/lisp-kernel/gc-common.c

    r15505 r15606  
    288288        pairp[0] = slot_unbound;
    289289        pairp[1] = empty_value;
    290         hashp->weak_deletions_count += (1<<fixnumshift);
     290        hashp->count += (1<<fixnumshift);
     291        if (!keys_frozen) {
     292          hashp->deleted_count += (1<<fixnumshift);
     293        }
    291294      }
    292295    }
  • trunk/source/lisp-kernel/linuxx8632/Makefile

    r15289 r15606  
    2222ASFLAGS = --32
    2323M4FLAGS = -DLINUX -DX86 -DX8632 -DHAVE_TLS
    24 CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8632 -D_GNU_SOURCE -DHAVE_TLS -DUSE_FUTEX -DSVN_REVISION=$(SVN_REVISION) #-DGC_INTEGRITY_CHECKING -DDISABLE_EGC
     24CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8632 -D_GNU_SOURCE -DHAVE_TLS -DSVN_REVISION=$(SVN_REVISION) # -DGC_INTEGRITY_CHECKING -DDISABLE_EGC
    2525CDEBUG = -g
    2626COPT = -O2
  • trunk/source/lisp-kernel/linuxx8664/Makefile

    r15289 r15606  
    2222ASFLAGS = --64
    2323M4FLAGS = -DLINUX -DX86 -DX8664 -DHAVE_TLS
    24 CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DUSE_FUTEX -DSVN_REVISION=$(SVN_REVISION) #-DDISABLE_EGC
     24CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS  -DSVN_REVISION=$(SVN_REVISION) #-DDISABLE_EGC -DUSE_FUTEX
    2525CDEBUG = -g
    2626COPT = -O2
  • trunk/source/lisp-kernel/lisp-debug.c

    r15600 r15606  
    420420      if ((program_counter != NULL) &&
    421421          (*program_counter == INTN_OPCODE)) {
    422         fprintf(dbgout, "unhandled int 0x%x instruction", program_counter[1]);
     422        fprintf(dbgout, "unhandled int 0x%x instruction\n", program_counter[1]);
    423423      }
    424424      return;
  • trunk/source/lisp-kernel/x86-constants32.h

    r15504 r15606  
    407407
    408408#define ABI_VERSION_MIN 1038
    409 #define ABI_VERSION_CURRENT 1038
    410 #define ABI_VERSION_MAX 1038
     409#define ABI_VERSION_CURRENT 1039
     410#define ABI_VERSION_MAX 1039
  • trunk/source/lisp-kernel/x86-constants64.h

    r15504 r15606  
    350350
    351351#define ABI_VERSION_MIN 1038
    352 #define ABI_VERSION_CURRENT 1038
    353 #define ABI_VERSION_MAX 1038
     352#define ABI_VERSION_CURRENT 1039
     353#define ABI_VERSION_MAX 1039
Note: See TracChangeset for help on using the changeset viewer.