Changeset 7624
- Timestamp:
- Nov 10, 2007, 5:22:11 AM (13 years ago)
- Location:
- branches/working-0711/ccl
- Files:
-
- 73 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/PPC/PPC32/ppc32-arch.lisp
r6456 r7624 470 470 malloced-ptr 471 471 spinlock) 472 473 (define-storage-layout rwlock 0 474 spin 475 state 476 blocked-writers 477 blocked-readers 478 writer 479 reader-signal 480 writer-signal 481 malloced-ptr 482 ) 472 483 473 484 ;;; For the eabi port: mark this stack frame as Lisp's (since EABI -
branches/working-0711/ccl/compiler/PPC/PPC64/ppc64-arch.lisp
r6457 r7624 548 548 malloced-ptr 549 549 spinlock) 550 551 (define-storage-layout rwlock 0 552 spin 553 state 554 blocked-writers 555 blocked-readers 556 writer 557 reader-signal 558 writer-signal 559 malloced-ptr 560 ) 550 561 551 562 ;;; For the eabi port: mark this stack frame as Lisp's (since EABI -
branches/working-0711/ccl/compiler/PPC/ppc-lapmacros.lisp
r5096 r7624 175 175 (:ppc32 `(slwi ,@args)) 176 176 (:ppc64 `(sldi ,@args)))) 177 178 (defppclapmacro slri. (&rest args) 179 (target-arch-case 180 (:ppc32 `(slwi. ,@args)) 181 (:ppc64 `(sldi. ,@args)))) 177 182 178 183 (defppclapmacro srr (&rest args) -
branches/working-0711/ccl/compiler/X86/X8664/x8664-arch.lisp
r6462 r7624 213 213 (defx86reg save3 r11) 214 214 (defx86reg save3.l r11d) 215 (defx86reg save3.w r1 0w)216 (defx86reg save3.b r1 0b)215 (defx86reg save3.w r11w) 216 (defx86reg save3.b r11b) 217 217 218 218 (defx86reg save2 r12) … … 724 724 malloced-ptr 725 725 spinlock) 726 727 (define-storage-layout rwlock 0 728 spin 729 state 730 blocked-writers 731 blocked-readers 732 writer 733 reader-signal 734 writer-signal 735 malloced-ptr 736 ) 726 737 727 738 (defmacro define-header (name element-count subtag) -
branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp
r7376 r7624 489 489 (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset 490 490 (incf memory-arg-offset (* 8 (ceiling bits 64))))))) 491 (dynamic-extent-names name))491 (dynamic-extent-names name)) 492 492 (progn 493 493 (rlets (list name (foreign-record-type-name argtype))) … … 511 511 (:unsigned-byte '%get-unsigned-byte) 512 512 (:address 513 ;(dynamic-extent-names name) 513 #+nil 514 (dynamic-extent-names name) 514 515 '%get-ptr)) 515 516 ,stack-ptr -
branches/working-0711/ccl/compiler/X86/x86-arch.lisp
r6930 r7624 40 40 area-lock ; serialize access to gc 41 41 exception-lock ; serialize exception handling 42 deleted-static-pairs ; hash-consing42 static-conses ; when FREEZE is in effect 43 43 default-allocation-quantum ; log2_heap_segment_size, as a fixnum. 44 44 intflag ; interrupt-pending flag -
branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp
r6996 r7624 826 826 827 827 (defun nop-fixup (ds bytemode sizeflag) 828 (declare (ignore bytemode sizeflag)) 828 (declare (ignore bytemode sizeflag) 829 (ignorable ds)) 830 #+nothing 829 831 (if (logtest (x86-ds-prefixes ds) +prefix-repz+) 830 832 (break "should be PAUSE"))) -
branches/working-0711/ccl/compiler/X86/x862.lisp
r7443 r7624 3644 3644 (case src-mode 3645 3645 (#.hard-reg-class-gpr-mode-node 3646 (! unbox-u32 dest src)) 3646 (if *x862-reckless* 3647 (! %unbox-u32 dest src) 3648 (! unbox-u32 dest src))) 3647 3649 ((#.hard-reg-class-gpr-mode-u32 3648 3650 #.hard-reg-class-gpr-mode-s32) … … 3660 3662 (case src-mode 3661 3663 (#.hard-reg-class-gpr-mode-node 3662 (! unbox-u16 dest src)) 3664 (if *x862-reckless* 3665 (! %unbox-u16 dest src) 3666 (! unbox-u16 dest src))) 3663 3667 ((#.hard-reg-class-gpr-mode-u8 3664 3668 #.hard-reg-class-gpr-mode-s8) -
branches/working-0711/ccl/compiler/arch.lisp
r5529 r7624 28 28 (defconstant tcr-flag-bit-foreign 0) 29 29 (defconstant tcr-flag-bit-awaiting-preset 1) 30 (defconstant tcr-flag-bit-alt-suspend 2) 31 (defconstant tcr-flag-bit-propagate-exception 3) 32 (defconstant tcr-flag-bit-suspend-ack-pending 4) 33 (defconstant tcr-flag-bit-pending-exception 5) 34 (defconstant tcr-flag-bit-foreign-exception 6) 35 (defconstant tcr-flag-bit-pending-suspend 7) 30 36 31 37 … … 52 58 (defconstant error-cant-take-car 8) 53 59 (defconstant error-cant-take-cdr 9) 60 (defconstant error-propagate-suspend 10) 54 61 (defconstant error-cant-call 17) ; Attempt to funcall something that is not a symbol or function. 55 62 (eval-when (:compile-toplevel :load-toplevel :execute) … … 323 330 (defconstant gc-trap-function-configure-egc 64) 324 331 (defconstant gc-trap-function-set-hons-area-size 128) 332 (defconstant gc-trap-function-freeze 129) 333 (defconstant gc-trap-function-thaw 130) 334 325 335 326 336 -
branches/working-0711/ccl/compiler/nx1.lisp
r6175 r7624 1661 1661 (%nx1-operator %immediate-set-xxx) 1662 1662 (case op 1663 (%%set-signed-longlong (logior 32 8))1664 (t 8))1663 (%%set-signed-longlong 8) 1664 (t (logior 32 8))) 1665 1665 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) 1666 1666 (nx1-form offset) -
branches/working-0711/ccl/compiler/optimizers.lisp
r6473 r7624 135 135 t)) 136 136 137 ;;; return new form if no keys (or if keys constant and specify :TEST 138 ;;; {#'eq, #'eql} only.) 139 (defun eq-eql-call (x l keys eq-fn eql-fn env) 140 (flet ((eql-to-eq () 141 (or (eql-iff-eq-p x env) 142 (and (or (quoted-form-p l) (null l)) 143 (dolist (elt (%cadr l) t) 144 (when (eq eq-fn 'assq) (setq elt (car elt))) 145 (when (and (numberp elt) (not (fixnump elt))) 146 (return nil))))))) 147 (if (null keys) 148 (list (if (eql-to-eq) eq-fn eql-fn) x l) 149 (if (constant-keywords-p keys) 137 (defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly) 138 (if (null keys) 139 `(,default ,item ,list) 140 (if (constant-keywords-p keys) 150 141 (destructuring-bind (&key (test nil test-p) 151 142 (test-not nil test-not-p) 152 143 (key nil key-p)) 153 144 keys 154 (declare (ignore test-not key))145 (declare (ignore test-not)) 155 146 (if (and test-p 156 (not test-not-p) 157 (not key-p) 147 (not test-not-p) 148 (or (not key-p) 149 (and (consp key) 150 (consp (%cdr key)) 151 (null (%cddr key)) 152 (or (eq (%car key) 'function) 153 (eq (%car key) 'quote)) 154 (eq (%cadr key) 'identity))) 158 155 (consp test) 159 156 (consp (%cdr test)) … … 161 158 (or (eq (%car test) 'function) 162 159 (eq (%car test) 'quote))) 163 (let ((testname (%cadr test))) 164 (if (or (eq testname 'eq) 165 (and (eq testname 'eql) 166 (eql-to-eq))) 167 (list eq-fn x l) 168 (if (and eql-fn (eq testname 'eql)) 169 (list eql-fn x l)))))))))) 160 (let* ((testname (%cadr test)) 161 (reduced (cdr (assoc testname alist)))) 162 (if reduced 163 `(,reduced ,item ,list) 164 `(,testonly ,item ,list ,test)))))))) 165 170 166 171 167 (defun eql-iff-eq-p (thing env) … … 174 170 (if (not (self-evaluating-p thing)) 175 171 (return-from eql-iff-eq-p 176 (nx-form-typep thing 177 '(or fixnum 178 #+64-bit-target single-float 179 character symbol 180 (and (not number) (not macptr))) env)))) 172 (or (nx-form-typep thing 'symbol env) 173 (nx-form-typep thing 'character env) 174 (nx-form-typep thing 175 '(or fixnum 176 #+64-bit-target single-float 177 symbol character 178 (and (not number) (not macptr))) env))))) 181 179 (or (fixnump thing) #+64-bit-target (typep thing 'single-float) 180 (symbolp thing) (characterp thing) 182 181 (and (not (numberp thing)) (not (macptrp thing))))) 182 183 (defun equal-iff-eql-p (thing env) 184 (if (quoted-form-p thing) 185 (setq thing (%cadr thing)) 186 (if (not (self-evaluating-p thing)) 187 (return-from equal-iff-eql-p 188 (nx-form-typep thing 189 '(and (not cons) (not string) (not bit-vector) (not pathname)) env)))) 190 (not (typep thing '(or cons string bit-vector pathname)))) 191 183 192 184 193 (defun fold-constant-subforms (call env) … … 330 339 331 340 332 (define-compiler-macro assoc (&whole call &environment envitem list &rest keys)333 (or ( eq-eql-call item list keys 'assq 'asseql env)341 (define-compiler-macro assoc (&whole call item list &rest keys) 342 (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test) 334 343 call)) 335 344 345 (define-compiler-macro assequal (&whole call &environment env item list) 346 (if (or (equal-iff-eql-p item env) 347 (and (quoted-form-p list) 348 (proper-list-p (%cadr list)) 349 (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list)))) 350 `(asseql ,item ,list) 351 call)) 352 353 (define-compiler-macro asseql (&whole call &environment env item list) 354 (if (or (eql-iff-eq-p item env) 355 (and (quoted-form-p list) 356 (proper-list-p (%cadr list)) 357 (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list)))) 358 `(assq ,item ,list) 359 call)) 360 361 (define-compiler-macro assq (item list) 362 (let* ((itemx (gensym)) 363 (listx (gensym)) 364 (pair (gensym))) 365 `(let* ((,itemx ,item) 366 (,listx ,list)) 367 (dolist (,pair ,listx) 368 (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair)))))) 336 369 337 370 (define-compiler-macro caar (form) … … 785 818 (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var))))))))) 786 819 787 (define-compiler-macro member (&whole call &environment envitem list &rest keys)788 (or ( eq-eql-call item list keys 'memq 'memeql env)820 (define-compiler-macro member (&whole call item list &rest keys) 821 (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test) 789 822 call)) 790 823 824 (define-compiler-macro memequal (&whole call &environment env item list) 825 (if (or (equal-iff-eql-p item env) 826 (and (quoted-form-p list) 827 (proper-list-p (%cadr list)) 828 (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list)))) 829 `(memeql ,item ,list) 830 call)) 831 832 (define-compiler-macro memeql (&whole call &environment env item list) 833 (if (or (eql-iff-eq-p item env) 834 (and (quoted-form-p list) 835 (proper-list-p (%cadr list)) 836 (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list)))) 837 `(memq ,item ,list) 838 call)) 839 791 840 (define-compiler-macro memq (&whole call &environment env item list) 792 793 794 841 ;;(memq x '(y)) => (if (eq x 'y) '(y)) 842 ;;Would it be worth making a two elt list into an OR? Maybe if 843 ;;optimizing for speed... 795 844 (if (and (or (quoted-form-p list) 796 845 (null list)) 797 846 (null (cdr (%cadr list)))) 798 847 (if list `(if (eq ,item ',(%caadr list)) ,list)) 799 call)) 848 (let* ((x (gensym)) 849 (tail (gensym))) 850 `(do* ((,x ,item) 851 (,tail ,list (cdr (the list ,tail)))) 852 ((null ,tail)) 853 (if (eq (car ,tail) ,x) (return ,tail)))))) 800 854 801 855 (define-compiler-macro minusp (x) … … 815 869 (%i< count 3)) 816 870 `(,(svref '#(car cadr caddr) count) ,list) 817 call))871 `(car (nthcdr ,count ,list)))) 818 872 819 873 (define-compiler-macro nthcdr (&whole call &environment env count list) … … 822 876 (%i< count 4)) 823 877 (if (%izerop count) 824 list878 `(require-type ,list 'list) 825 879 `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list)) 826 call)) 880 (let* ((i (gensym)) 881 (n (gensym)) ; evaluation order 882 (tail (gensym))) 883 `(let* ((,n (require-type ,count 'unsigned-byte)) 884 (,tail (require-type ,list 'list))) 885 (dotimes (,i ,n ,tail) 886 (unless (setq ,tail (cdr ,tail)) 887 (return nil))))))) 827 888 828 889 (define-compiler-macro plusp (x) … … 1814 1875 `(float ,thing 0.0d0) 1815 1876 call))) 1816 1877 1878 (define-compiler-macro equal (&whole call x y &environment env) 1879 (if (or (equal-iff-eql-p x env) 1880 (equal-iff-eql-p y env)) 1881 `(eql ,x ,y) 1882 call)) 1817 1883 1818 1884 (provide "OPTIMIZERS") -
branches/working-0711/ccl/level-0/PPC/ppc-misc.lisp
r7343 r7624 551 551 (blr)) 552 552 553 ;;; Return true iff we were able to increment a non-negative 554 ;;; lock._value 555 (defppclapfunction %try-read-lock-rwlock ((lock arg_z)) 556 (check-nargs 1) 557 (li imm1 target::lock._value) 558 @try 559 (lrarx imm0 lock imm1) 560 (cmpri imm0 0) 561 (blt @fail) ; locked for writing 562 (addi imm0 imm0 '1) 563 (strcx. imm0 lock imm1) 564 (bne @try) ; lost reservation, try again 565 (isync) 566 (blr) ; return the lock 567 @fail 568 (li imm0 target::reservation-discharge) 569 (strcx. rzero rzero imm0) 570 (li arg_z nil) 571 (blr)) 572 573 574 575 (defppclapfunction unlock-rwlock ((lock arg_z)) 576 (ldr imm2 target::lock._value lock) 577 (cmpri imm2 0) 578 (li imm1 target::lock._value) 579 (ble @unlock-write) 580 @unlock-read 581 (lrarx imm0 lock imm1) 582 (subi imm0 imm0 '1) 583 (strcx. imm0 lock imm1) 584 (bne @unlock-read) 585 (isync) 586 (blr) 587 @unlock-write 588 ;;; If we aren't the writer, return NIL. 589 ;;; If we are and the value's about to go to 0, clear the writer field. 590 (ldr imm0 target::lock.writer lock) 591 (cmpr imm0 target::rcontext) 592 (ldrx imm0 lock imm1) 593 (cmpri cr1 imm0 '-1) 594 (addi imm0 imm0 '1) 595 (bne @fail) 596 (bne cr1 @noclear) 597 (str rzero target::lock.writer lock) 598 @noclear 599 (str imm0 target::lock._value lock) 600 (blr) 601 @fail 602 (li arg_z nil) 603 (blr)) 553 604 554 605 555 (defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) … … 1022 972 (blr)) 1023 973 974 (defppclapfunction %check-deferred-gc () 975 (ldr imm0 target::tcr.flags target::rcontext) 976 (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift))) 977 (li arg_z nil) 978 (bgelr) 979 (uuo_interr arch::error-propagate-suspend rzero) 980 (li arg_z t) 981 (blr)) 982 1024 983 1025 984 ; end of ppc-misc.lisp -
branches/working-0711/ccl/level-0/X86/x86-array.lisp
r6476 r7624 26 26 27 27 28 29 30 ;; rewrite in LAP someday (soon). 28 #+x8664-target 29 (progn 30 ;;; None of the stores in here can be intergenerational; the vector 31 ;;; is known to be younger than the initial value 32 (defx86lapfunction %init-gvector ((len arg_x) (value arg_y) (vector arg_z)) 33 (jmp @test) 34 @loop 35 (movq (% value) (@ x8664::misc-data-offset (% vector) (% len))) 36 @test 37 (subq ($ x8664::fixnumone) (% len)) 38 (jns @loop) 39 (single-value-return)) 40 41 ;;; "val" is either a fixnum or a uvector with 64-bits of data 42 ;;; (small bignum, DOUBLE-FLOAT). 43 (defx86lapfunction %%init-ivector64 ((len arg_x) (value arg_y) (vector arg_z)) 44 (unbox-fixnum value imm0) 45 (testb ($ x8664::fixnummask) (%b value)) 46 (je @test) 47 (movq (@ x8664::misc-data-offset (% value)) (% imm0)) 48 (jmp @test) 49 @loop 50 (movq (% imm0) (@ x8664::misc-data-offset (% vector) (% len))) 51 @test 52 (subq ($ x8664::fixnumone) (% len)) 53 (jns @loop) 54 (single-value-return)) 55 56 (defun %init-ivector64 (typecode len val uvector) 57 (declare (type (mod 256) typecode)) 58 (%%init-ivector64 len 59 (case typecode 60 (#.x8664::subtag-fixnum-vector 61 (require-type val 'fixnum)) 62 (#.x8664::subtag-double-float-vector 63 (if (typep val 'double-float) 64 val 65 (require-type val 'double-float))) 66 (#.x8664::subtag-s64-vector 67 (require-type val '(signed-byte 64))) 68 (#.x8664::subtag-u64-vector 69 (require-type val '(unsigned-byte 64))) 70 (t (report-bad-arg uvector 71 '(or (simple-array fixnum (*)) 72 (simple-array double-float (*)) 73 (simple-array (signed-byte 64) (*)) 74 (simple-array (unsigned-byte 64) (*)))))) 75 uvector)) 76 77 78 (eval-when (:compile-toplevel :execute) 79 (declaim (inline %init-ivector-u32))) 80 81 (defun %init-ivector-u32 (len u32val uvector) 82 (declare (type index len) 83 (type (unsigned-byte 32) u32val) 84 (type (simple-array (unsigned-byte 32) (*)) uvector) 85 (optimize (speed 3) (safety 0))) 86 (dotimes (i len uvector) 87 (setf (aref uvector i) u32val))) 88 89 (eval-when (:compile-toplevel :execute) 90 (declaim (inline %init-ivector-u16))) 91 92 (defun %init-ivector-u16 (len val uvector) 93 (declare (type index len) 94 (type (unsigned-byte 16) val) 95 (type (simple-array (unsigned-byte 16) (*)) uvector) 96 (optimize (speed 3) (safety 0))) 97 (dotimes (i len uvector) 98 (setf (aref uvector i) val))) 99 100 101 102 (defun %init-ivector32 (typecode len val uvector) 103 (declare (type (unsigned-byte 32) typecode) 104 (type index len)) 105 (let* ((u32val (case typecode 106 (#.x8664::subtag-s32-vector 107 (logand (the (signed-byte 32) 108 (require-type val '(signed-byte 32))) 109 #xffffffff)) 110 (#.x8664::subtag-single-float-vector 111 (single-float-bits (require-type val 'single-float))) 112 (#.x8664::subtag-simple-base-string 113 (char-code val)) 114 (t 115 (require-type val '(unsigned-byte 32)))))) 116 (declare (type (unsigned-byte 32) u32val)) 117 (%init-ivector-u32 len u32val uvector))) 118 119 (defun %init-misc (val uvector) 120 (let* ((len (uvsize uvector)) 121 (typecode (typecode uvector)) 122 (fulltag (logand x8664::fulltagmask typecode))) 123 (declare (type index len) 124 (type (unsigned-byte 8) typecode) 125 (type (mod 16) fulltag)) 126 (if (or (= fulltag x8664::fulltag-nodeheader-0) 127 (= fulltag x8664::fulltag-nodeheader-1)) 128 (%init-gvector len val uvector) 129 (if (= fulltag x8664::ivector-class-64-bit) 130 (%init-ivector64 typecode len val uvector) 131 (if (= fulltag x8664::ivector-class-32-bit) 132 (%init-ivector32 typecode len val uvector) 133 ;; Value must be a fixnum, 1, 8, 16 bits 134 (case typecode 135 (#.x8664::subtag-u16-vector 136 (%init-ivector-u16 len 137 (require-type val '(unsigned-byte 16)) 138 uvector)) 139 (#.x8664::subtag-s16-vector 140 (%init-ivector-u16 len 141 (logand (the (signed-byte 16) 142 (require-type val '(unsigned-byte 16))) 143 #xffff) 144 uvector)) 145 (#.x8664::subtag-u8-vector 146 (let* ((v0 (require-type val '(unsigned-byte 8))) 147 (l0 (ash (the fixnum (1+ len)) -1))) 148 (declare (type (unsigned-byte 8) v0) 149 (type index l0)) 150 (%init-ivector-u16 l0 151 (logior (the (unsigned-byte 16) (ash v0 8)) 152 v0) 153 uvector))) 154 (#.x8664::subtag-s8-vector 155 (let* ((v0 (logand #xff 156 (the (signed-byte 8) 157 (require-type val '(signed-byte 8))))) 158 (l0 (ash (the fixnum (1+ len)) -1))) 159 (declare (type (unsigned-byte 8) v0) 160 (type index l0)) 161 (%init-ivector-u16 l0 162 (logior (the (unsigned-byte 16) (ash v0 8)) 163 v0) 164 uvector))) 165 (#.x8664::subtag-bit-vector 166 (if (eql 0 val) 167 uvector 168 (let* ((v0 (case val 169 (1 -1) 170 (t (report-bad-arg val 'bit)))) 171 (l0 (ash (the fixnum (+ len 64)) -6))) 172 (declare (type (unsigned-byte 8) v0) 173 (type index l0)) 174 (%%init-ivector64 l0 v0 uvector)))) 175 (t (report-bad-arg uvector 176 '(or simple-bit-vector 177 (simple-array (signed-byte 8) (*)) 178 (simple-array (unsigned-byte 8) (*)) 179 (simple-array (signed-byte 16) (*)) 180 (simple-array (unsigned-byte 16) (*))))))))))) 181 182 183 ) 184 185 #-x8664-target 31 186 (defun %init-misc (val uvector) 32 187 (dotimes (i (uvsize uvector) uvector) 33 188 (setf (uvref uvector i) val))) 34 189 35 190 36 191 ;;; Make a new vector of size newsize whose subtag matches that of oldv-arg. -
branches/working-0711/ccl/level-0/X86/x86-clos.lisp
r6477 r7624 35 35 (shrq ($ x8664::word-shift) (% imm1)) 36 36 (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) 37 (shlq ($ x8664::word-shift) (% imm1))38 37 @have-table-index 39 38 (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) -
branches/working-0711/ccl/level-0/X86/x86-misc.lisp
r7343 r7624 393 393 ;;; Return true iff we were able to increment a non-negative 394 394 ;;; lock._value 395 (defx86lapfunction %try-read-lock-rwlock ((lock arg_z)) 396 (check-nargs 1) 397 @try 398 (movq (@ x8664::lock._value (% lock)) (% rax)) 399 (movq (% rax) (% imm1)) 400 (addq ($ '1) (% imm1)) 401 (jle @fail) 402 (lock) 403 (cmpxchgq (% imm1) (@ x8664::lock._value (% lock))) 404 (jne @try) 405 (single-value-return) ; return the lock 406 @fail 407 (movl ($ x8664::nil-value) (%l arg_z)) 408 (single-value-return)) 409 410 411 412 (defx86lapfunction unlock-rwlock ((lock arg_z)) 413 (cmpq ($ 0) (@ x8664::lock._value (% lock))) 414 (jle @unlock-write) 415 @unlock-read 416 (movq (@ x8664::lock._value (% lock)) (% rax)) 417 (lea (@ '-1 (% imm0)) (% imm1)) 418 (lock) 419 (cmpxchgq (% imm1) (@ x8664::lock._value (% lock))) 420 (jne @unlock-read) 421 (single-value-return) 422 @unlock-write 423 ;;; If we aren't the writer, return NIL. 424 ;;; If we are and the value's about to go to 0, clear the writer field. 425 (movq (@ x8664::lock.writer (% lock)) (% imm0)) 426 (cmpq (% imm0) (@ (% :rcontext) x8664::tcr.linear)) 427 (jne @fail) 428 (cmpq ($ '-1) (@ x8664::lock._value (% lock))) 429 (jne @still-owner) 430 (movsd (% fpzero) (@ x8664::lock.writer (% lock))) 431 @still-owner 432 (addq ($ '1) (@ x8664::lock._value (% lock))) 433 (single-value-return) 434 @fail 435 (movl ($ x8664::nil-value) (%l arg_z)) 436 (single-value-return)) 395 396 397 437 398 438 399 (defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) … … 535 496 (movq (% imm0) (% arg_z)) 536 497 (single-value-return))) 498 499 (defx86lapfunction xchgl ((newval arg_y) (ptr arg_z)) 500 (unbox-fixnum newval imm0) 501 (macptr-ptr ptr arg_y) ; had better be aligned 502 (lock) ; implicit ? 503 (xchgl (% imm0.l) (@ (% arg_y))) 504 (box-fixnum imm0 arg_z) 505 (single-value-return)) 506 507 537 508 538 509 … … 750 721 ;;; it still called ? 751 722 723 (defx86lapfunction %check-deferred-gc () 724 (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (@ (% :rcontext) x8664::tcr.flags)) 725 (movl ($ x8664::nil-value) (% arg_z.l)) 726 (jae @done) 727 (ud2a) 728 (:byte 3) 729 (movl ($ x8664::t-value) (% arg_z.l)) 730 @done 731 (single-value-return)) 732 733 (defx86lapfunction %get-spin-lock ((p arg_z)) 734 (check-nargs 1) 735 (save-simple-frame) 736 @again 737 (macptr-ptr arg_z imm1) 738 (movq (@ '*spin-lock-tries* (% fn)) (% temp0)) 739 (movq (@ target::symbol.vcell (% temp0)) (% temp0)) 740 (movq (@ (% :rcontext) x8664::tcr.linear) (% arg_y)) 741 @try-swap 742 (xorq (% rax) (% rax)) 743 (lock) 744 (cmpxchgq (% arg_y) (@ (% imm1))) 745 (je @done) 746 (pause) 747 (subq ($ '1) (% temp0)) 748 (jne @try-swap) 749 (pushq (% arg_z)) 750 (call-symbol yield 0) 751 (popq (% arg_z)) 752 (jmp @again) 753 @done 754 (restore-simple-frame) 755 (single-value-return)) 756 752 757 753 758 ;;; end of x86-misc.lisp -
branches/working-0711/ccl/level-0/X86/x86-utils.lisp
r6483 r7624 443 443 (single-value-return)) 444 444 445 (defx86lapfunction freeze () 446 "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." 447 (movq ($ arch::gc-trap-function-freeze) (% imm0)) 448 (uuo-gc-trap) 449 (jmp-subprim .SPmakeu64)) 450 451 452 445 453 446 454 -
branches/working-0711/ccl/level-0/l0-aprims.lisp
r7451 r7624 22 22 ;;; This weak list is used to track semaphores as well as locks. 23 23 (defvar %system-locks% nil) 24 (setf %system-locks% (%cons-population nil)) 24 25 25 26 26 (defun record-system-lock (l) … … 71 71 (when nul-terminated 72 72 (setf (%get-byte pointer n) 0))) 73 nil) 74 (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)))73 nil)) 74 (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)) 75 75 76 76 (defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t)) … … 123 123 :address)))) 124 124 125 125 (defun %make-rwlock-ptr () 126 (record-system-lock 127 (%setf-macptr 128 (make-gcable-macptr $flags_DisposeRwLock) 129 (ff-call (%kernel-import target::kernel-import-rwlock-new) 130 :address)))) 126 131 127 132 (defun make-recursive-lock () … … 142 147 (report-bad-arg r 'recursive-lock))) 143 148 144 149 (defun read-write-lock-ptr (rw) 150 (if (and (eq target::subtag-lock (typecode rw)) 151 (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) 152 (%svref rw target::lock._value-cell) 153 (report-bad-arg rw 'read-write-lock))) 145 154 146 155 (defun make-read-write-lock () 147 156 "Create and return a read-write lock, which can be used for 148 157 synchronization between threads." 149 (gvector :lock 0'read-write-lock 0 nil))158 (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil)) 150 159 151 160 -
branches/working-0711/ccl/level-0/l0-bignum64.lisp
r5837 r7624 2068 2068 2069 2069 2070 (defun %bignum-random (number state) 2071 (let* ((ndigits (%bignum-length number)) 2072 (sign-index (1- ndigits))) 2073 (declare (fixnum ndigits sign-index)) 2074 (with-bignum-buffers ((bignum ndigits)) 2075 (dotimes (i sign-index) 2076 (setf (bignum-ref bignum i) (%next-random-seed state))) 2077 (setf (bignum-ref bignum sign-index) 2078 (logand #x7fffffff (the (unsigned-byte 32) 2079 (%next-random-seed state)))) 2080 (let* ((result (mod bignum number))) 2081 (if (eq result bignum) 2082 (copy-uvector bignum) 2083 result))))) 2084 2085 2086 2070 2087 (defun logbitp (index integer) 2071 2088 "Predicate returns T if bit index of integer is a 1." -
branches/working-0711/ccl/level-0/l0-hash.lisp
r6918 r7624 187 187 find ; nhash.find 188 188 find-new ; nhash.find-new 189 nil ; hhash.read-only 189 190 )) 190 191 … … 567 568 568 569 569 570 571 570 (defvar *continue-from-readonly-hashtable-lock-error* nil) 571 572 (defun signal-read-only-hash-table-error (hash write-p) 573 (cond (*continue-from-readonly-hashtable-lock-error* 574 (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!" 575 "Hash-table ~s is readonly" hash) 576 (assert-hash-table-writeable hash) 577 (lock-hash-table hash write-p)) 578 (t (error "Hash-table ~s is readonly" hash)))) 579 580 (defun lock-hash-table (hash write-p) 581 (if (nhash.read-only hash) 582 (if write-p 583 (signal-read-only-hash-table-error hash write-p) 584 :readonly) 585 (let* ((lock (nhash.exclusion-lock hash))) 586 (if lock 587 (write-lock-rwlock lock) 588 (progn (unless (eq (nhash.owner hash) *current-process*) 589 (error "Not owner of hash table ~s" hash))))))) 590 591 (defun lock-hash-table-for-map (hash) 592 (if (nhash.read-only hash) 593 :readonly 594 (let* ((lock (nhash.exclusion-lock hash))) 595 (if lock 596 (write-lock-rwlock lock) 597 (progn (unless (eq (nhash.owner hash) *current-process*) 598 (error "Not owner of hash table ~s" hash))))))) 599 600 601 (defun unlock-hash-table (hash was-readonly) 602 (unless was-readonly 603 (let* ((lock (nhash.exclusion-lock hash))) 604 (if lock 605 (unlock-rwlock lock))))) 572 606 573 607 … … 579 613 (report-bad-arg hash 'hash-table)) 580 614 (without-interrupts 581 (lock-hash-table hash )615 (lock-hash-table hash t) 582 616 (let* ((vector (nhash.vector hash)) 583 617 (size (nhash.vector-size vector)) … … 600 634 (nhash.vector.flags vector) (logand $nhash_weak_flags_mask 601 635 (nhash.vector.flags vector)))) 602 (unlock-hash-table hash )636 (unlock-hash-table hash nil) 603 637 hash)) 604 638 … … 654 688 655 689 656 (defun lock-hash-table (hash)657 (let* ((lock (nhash.exclusion-lock hash)))658 (if lock659 (write-lock-rwlock lock)660 (progn (unless (eq (nhash.owner hash) *current-process*)661 (error "Not owner of hash table ~s" hash))))))662 663 (defun unlock-hash-table (hash)664 (let* ((lock (nhash.exclusion-lock hash)))665 (if lock666 (unlock-rwlock lock))))667 690 668 691 (defun gethash (key hash &optional default) … … 675 698 (vector-key nil) 676 699 (gc-locked nil) 700 (readonly nil) 677 701 (foundp nil)) 678 702 (without-interrupts 679 ( lock-hash-table hash)703 (setq readonly (eq (lock-hash-table hash nil) :readonly)) 680 704 (let* ((vector (nhash.vector hash))) 681 705 (if (and (eq key (nhash.vector.cache-key vector)) … … 694 718 (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker)) 695 719 (not (eq vector-key deleted-hash-key-marker)))) 720 #+no 696 721 (setf (nhash.vector.cache-key vector) vector-key 697 722 (nhash.vector.cache-value vector) value … … 705 730 (t (return))))))) 706 731 (when gc-locked (%unlock-gc-lock)) 707 (unlock-hash-table hash ))732 (unlock-hash-table hash readonly)) 708 733 (if foundp 709 734 (values value t) … … 717 742 (let* ((foundp nil)) 718 743 (without-interrupts 719 (lock-hash-table hash )744 (lock-hash-table hash t) 720 745 (%lock-gc-lock) 721 746 (when (%needs-rehashing-p hash) … … 728 753 (unless (= (the fixnum (hti.index iterator)) 729 754 (the fixnum (nhash.vector.cache-idx vector))) 730 (unlock-hash-table hash )755 (unlock-hash-table hash nil) 731 756 (%unlock-gc-lock) 732 757 (error "Can't remove key ~s during iteration on hash-table ~s" … … 749 774 (unless (= (the fixnum (hti.index iterator)) 750 775 (the fixnum (vector-index->index vector-index))) 751 (unlock-hash-table hash )776 (unlock-hash-table hash nil) 752 777 (%unlock-gc-lock) 753 778 (error "Can't remove key ~s during iteration on hash-table ~s" … … 782 807 ;; Return T if we deleted something 783 808 (%unlock-gc-lock) 784 (unlock-hash-table hash ))809 (unlock-hash-table hash nil)) 785 810 foundp)) 786 811 … … 792 817 (block protected 793 818 (tagbody 794 (lock-hash-table hash )819 (lock-hash-table hash t) 795 820 AGAIN 796 821 (%lock-gc-lock) … … 805 830 (when (and (< index (the fixnum (uvsize vector))) 806 831 (not (funcall test (%svref vector index) key))) 807 (unlock-hash-table hash )832 (unlock-hash-table hash nil) 808 833 (%unlock-gc-lock) 809 834 (error "Can't add key ~s during iteration on hash-table ~s" … … 850 875 (nhash.vector.cache-value vector) value))))) 851 876 (%unlock-gc-lock) 852 (unlock-hash-table hash ))877 (unlock-hash-table hash nil)) 853 878 value) 854 879 … … 1680 1705 vector)) 1681 1706 1707 (defun assert-hash-table-readonly (hash) 1708 (unless (hash-table-p hash) 1709 (report-bad-arg hash 'hash-table)) 1710 (or (nhash.read-only hash) 1711 (without-interrupts 1712 (lock-hash-table hash t) 1713 (let* ((flags (nhash.vector.flags (nhash.vector hash)))) 1714 (declare (fixnum flags)) 1715 (when (or (logbitp $nhash_track_keys_bit flags) 1716 (logbitp $nhash_component_address_bit flags)) 1717 (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash) 1718 (unlock-hash-table hash nil) 1719 (return-from assert-hash-table-readonly nil)) 1720 (setf (nhash.read-only hash) t) 1721 (unlock-hash-table hash nil) 1722 t)))) 1723 1724 ;; This is dangerous, if multiple threads are accessing a read-only 1725 ;; hash table. Use it responsibly. 1726 (defun assert-hash-table-writeable (hash) 1727 (unless (hash-table-p hash) 1728 (report-bad-arg hash 'hash-table)) 1729 (when (nhash.read-only hash) 1730 (setf (nhash.read-only hash) nil) 1731 t)) 1732 1733 (defun readonly-hash-table-p (hash) 1734 (unless (hash-table-p hash) 1735 (report-bad-arg hash 'hash-table)) 1736 (nhash.read-only hash)) -
branches/working-0711/ccl/level-0/l0-io.lisp
r6181 r7624 31 31 32 32 33 ; write nbytes bytes from buffer buf to file-descriptor fd. 33 (defun utf-8-octets-in-string (string start end) 34 (if (>= end start) 35 (do* ((noctets 0) 36 (i start (1+ i))) 37 ((= i end) noctets) 38 (declare (fixnum noctets)) 39 (let* ((code (char-code (schar string i)))) 40 (declare (type (mod #x110000) code)) 41 (incf noctets 42 (if (< code #x80) 43 1 44 (if (< code #x800) 45 2 46 (if (< code #x10000) 47 3 48 4)))))) 49 0)) 50 51 (defun utf-8-memory-encode (string pointer idx start end) 52 (declare (fixnum idx)) 53 (do* ((i start (1+ i))) 54 ((>= i end) idx) 55 (let* ((code (char-code (schar string i)))) 56 (declare (type (mod #x110000) code)) 57 (cond ((< code #x80) 58 (setf (%get-unsigned-byte pointer idx) code) 59 (incf idx)) 60 ((< code #x800) 61 (setf (%get-unsigned-byte pointer idx) 62 (logior #xc0 (the fixnum (ash code -6)))) 63 (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) 64 (logior #x80 (the fixnum (logand code #x3f)))) 65 (incf idx 2)) 66 ((< code #x10000) 67 (setf (%get-unsigned-byte pointer idx) 68 (logior #xe0 (the fixnum (ash code -12)))) 69 (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) 70 (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) 71 (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) 72 (logior #x80 (the fixnum (logand code #x3f)))) 73 (incf idx 3)) 74 (t 75 (setf (%get-unsigned-byte pointer idx) 76 (logior #xf0 77 (the fixnum (logand #x7 (the fixnum (ash code -18)))))) 78 (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) 79 (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) 80 (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) 81 (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) 82 (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) 83 (logand #x3f code)) 84 (incf idx 4)))))) 85 86 (defun utf-8-memory-decode (pointer noctets idx string) 87 (declare (fixnum noctets idx)) 88 (do* ((i 0 (1+ i)) 89 (end (+ idx noctets)) 90 (index idx (1+ index))) 91 ((>= index end) (if (= index end) index 0)) 92 (let* ((1st-unit (%get-unsigned-byte pointer index))) 93 (declare (type (unsigned-byte 8) 1st-unit)) 94 (let* ((char (if (< 1st-unit #x80) 95 (code-char 1st-unit) 96 (if (>= 1st-unit #xc2) 97 (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) 98 (declare (type (unsigned-byte 8) 2nd-unit)) 99 (if (< 1st-unit #xe0) 100 (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) 101 (code-char 102 (logior 103 (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) 104 (the fixnum (logxor 2nd-unit #x80))))) 105 (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) 106 (declare (type (unsigned-byte 8) 3rd-unit)) 107 (if (< 1st-unit #xf0) 108 (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) 109 (< (the fixnum (logxor 3rd-unit #x80)) #x40) 110 (or (>= 1st-unit #xe1) 111 (>= 2nd-unit #xa0))) 112 (code-char (the fixnum 113 (logior (the fixnum 114 (ash (the fixnum (logand 1st-unit #xf)) 115 12)) 116 (the fixnum 117 (logior 118 (the fixnum 119 (ash (the fixnum (logand 2nd-unit #x3f)) 120 6)) 121 (the fixnum (logand 3rd-unit #x3f)))))))) 122 (if (< 1st-unit #xf8) 123 (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) 124 (declare (type (unsigned-byte 8) 4th-unit)) 125 (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) 126 (< (the fixnum (logxor 3rd-unit #x80)) #x40) 127 (< (the fixnum (logxor 4th-unit #x80)) #x40) 128 (or (>= 1st-unit #xf1) 129 (>= 2nd-unit #x90))) 130 (code-char 131 (logior 132 (the fixnum 133 (logior 134 (the fixnum 135 (ash (the fixnum (logand 1st-unit 7)) 18)) 136 (the fixnum 137 (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) 138 (the fixnum 139 (logior 140 (the fixnum 141 (ash (the fixnum (logxor 3rd-unit #x80)) 6)) 142 (the fixnum (logxor 4th-unit #x80))))))))))))))))) 143 (setf (schar string i) (or char #\Replacement_Character)))))) 144 145 (defun utf-8-length-of-memory-encoding (pointer noctets start) 146 (do* ((i start) 147 (end (+ start noctets)) 148 (nchars 0 (1+ nchars))) 149 ((= i end) (values nchars i)) 150 (let* ((code (%get-unsigned-byte pointer i)) 151 (nexti (+ i (cond ((< code #x80) 1) 152 ((< code #xe0) 2) 153 ((< code #xf0) 3) 154 (t 4))))) 155 (declare (type (unsigned-byte 8) code)) 156 (if (> nexti end) 157 (return (values nchars i)) 158 (setq i nexti))))) 159 160 161 162 ;;; write nbytes bytes from buffer buf to file-descriptor fd. 34 163 (defun fd-write (fd buf nbytes) 35 164 (syscall syscalls::write fd buf nbytes)) … … 42 171 43 172 (defun fd-open (path flags &optional (create-mode #o666)) 44 (with-cstrs ((p path)) 45 (syscall syscalls::open p flags create-mode))) 173 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path)) 174 (let* ((fd (syscall syscalls::open p flags create-mode))) 175 (declare (fixnum fd)) 176 (when (or (= fd (- #$EMFILE)) 177 (= fd (- #$EMFILE))) 178 (gc) 179 (drain-termination-queue) 180 (setq fd (syscall syscalls::open p flags create-mode))) 181 fd))) 46 182 47 183 (defun fd-chmod (fd mode) -
branches/working-0711/ccl/level-0/l0-misc.lisp
r6917 r7624 16 16 17 17 (in-package "CCL") 18 19 ;;; Bootstrapping for futexes 20 #+(and linuxx8664-target) 21 (eval-when (:compile-toplevel :execute) 22 (pushnew :futex *features*)) 23 24 #+futex 25 (eval-when (:compile-toplevel :execute) 26 ;; We only need a few constants from <linux/futex.h>, which may 27 ;; not have been included in the :libc .cdb files. 28 (defconstant FUTEX-WAIT 0) 29 (defconstant FUTEX-WAKE 1) 30 (defconstant futex-avail 0) 31 (defconstant futex-locked 1) 32 (defconstant futex-contended 2) 33 (require "X8664-LINUX-SYSCALLS") 34 (declaim (inline %lock-futex %unlock-futex))) 18 35 19 36 ; Miscellany. … … 129 146 t) 130 147 131 148 (defun frozen-space-dnodes () 149 "Returns the current size of the frozen area." 150 (%fixnum-ref-natural (%get-kernel-global 'tenured-area) 151 target::area.static-dnodes)) 132 152 (defun %usedbytes () 133 153 (%normalize-areas) … … 147 167 (incf library bytes) 148 168 (incf static bytes)))))) 149 (let* (( hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift)))150 (decf dynamic hons-size)151 (values dynamic static library hons-size))))169 (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift))) 170 (decf dynamic frozen-size) 171 (values dynamic static library frozen-size)))) 152 172 153 173 … … 199 219 200 220 201 ; Returns six values.202 ; sp free203 ; sp used204 ; vsp free205 ; vsp used206 ; tsp free207 ; tsp used221 ;;; Returns six values. 222 ;;; sp free 223 ;;; sp used 224 ;;; vsp free 225 ;;; vsp used 226 ;;; tsp free 227 ;;; tsp used 208 228 (defun %thread-stack-space (&optional (thread *current-lisp-thread*)) 209 229 (when (eq thread *current-lisp-thread*) … … 267 287 (static-used nil) 268 288 (staticlib-used nil) 269 ( hons-space-size nil)289 (frozen-space-size nil) 270 290 (lispheap nil) 271 291 (reserved nil) … … 275 295 (stack-free) 276 296 (stack-used-by-thread nil)) 277 ( with-other-threads-suspended278 (without-gcing279 280 281 (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)282 283 284 285 static (+ static-used staticlib-used hons-space-size))286 287 288 289 297 (progn 298 (progn 299 (setq freebytes (%freebytes)) 300 (when verbose 301 (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size) 302 (%usedbytes)) 303 (setq lispheap (+ freebytes usedbytes) 304 reserved (%reservedbytes) 305 static (+ static-used staticlib-used frozen-space-size)) 306 (multiple-value-setq (stack-total stack-used stack-free) 307 (%stack-space)) 308 (unless (eq verbose :default) 309 (setq stack-used-by-thread (%stack-space-by-lisp-thread)))))) 290 310 (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes) 291 311 (when verbose … … 305 325 0 0 306 326 static (k static)) 307 (when (and hons-space-size (not (zerop hons-space-size)))308 (format t "~&~,3f MB of static memory reserved for hash consing."309 (/ hons-space-size (float (ash 1 20)))))327 (when (and frozen-space-size (not (zerop frozen-space-size))) 328 (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory" 329 (/ frozen-space-size (float (ash 1 20))))) 310 330 (format t "~&~,3f MB reserved for heap expansion." 311 331 (/ reserved (float (ash 1 20)))) … … 390 410 (declare (fixnum end)))) 391 411 412 (defun %get-utf-8-cstring (pointer) 413 (do* ((end 0 (1+ end))) 414 ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) 415 (let* ((len (utf-8-length-of-memory-encoding pointer end 0)) 416 (string (make-string len))) 417 (utf-8-memory-decode pointer end 0 string) 418 string)) 419 (declare (fixnum end)))) 420 392 421 ;;; This is mostly here so we can bootstrap shared libs without 393 422 ;;; having to bootstrap #_strcmp. … … 467 496 468 497 (defparameter *spin-lock-tries* 1) 469 498 (defparameter *spin-lock-timeouts* 0) 499 500 #+(and (not futex) (not x86-target)) 470 501 (defun %get-spin-lock (p) 471 502 (let* ((self (%current-tcr)) … … 476 507 (when (eql 0 (%ptr-store-fixnum-conditional p 0 self)) 477 508 (return-from %get-spin-lock t))) 509 (%atomic-incf-node 1 '*spin-lock-timeouts* target::symbol.vcell) 478 510 (yield)))) 479 511 512 #-futex 480 513 (defun %lock-recursive-lock (lock &optional flag) 481 514 (with-macptrs ((p) … … 505 538 (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock")))) 506 539 540 #+futex 541 (defun futex-wait (p val) 542 (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0)) 543 544 #+futex 545 (defun futex-wake (p n) 546 (syscall syscalls::futex p FUTEX-WAKE n (%null-ptr) (%null-ptr) 0)) 547 548 #+futex 549 (defun %lock-futex (p wait-level) 550 (let* ((val (%ptr-store-conditional p futex-avail futex-locked))) 551 (declare (fixnum val)) 552 (or (eql val futex-avail) 553 (loop 554 (if (eql val futex-contended) 555 (let* ((*interrupt-level* wait-level)) 556 (futex-wait p val)) 557 (setq val futex-contended)) 558 (when (eql futex-avail (xchgl val p)) 559 (return t)))))) 560 561 #+futex 562 (defun %unlock-futex (p) 563 (unless (eql futex-avail (%atomic-decf-ptr p)) 564 (setf (%get-natural p target::lockptr.avail) futex-avail) 565 (futex-wake p #$INT_MAX))) 566 567 568 #+futex 569 (defun %lock-recursive-lock (lock &optional flag) 570 (if (istruct-typep flag 'lock-acquisition) 571 (setf (lock-acquisition.status flag) nil) 572 (if flag (report-bad-arg flag 'lock-acquisition))) 573 (let* ((self (%current-tcr)) 574 (level *interrupt-level*)) 575 (declare (fixnum self val)) 576 (without-interrupts 577 (cond ((eql self (%get-object lock target::lockptr.owner)) 578 (incf (%get-natural lock target::lockptr.count))) 579 (t (%lock-futex lock level) 580 (%set-object lock target::lockptr.owner self) 581 (setf (%get-natural lock target::lockptr.count) 1))) 582 (when flag 583 (setf (lock-acquisition.status flag) t)) 584 t))) 585 586 507 587 508 588 ;;; Locking the exception lock to inhibit GC (from other threads) … … 522 602 (%unlock-recursive-lock lock))) 523 603 604 #-futex 524 605 (defun %try-recursive-lock (lock &optional flag) 525 606 (with-macptrs ((p) … … 546 627 win)))))) 547 628 548 629 #+futex 630 (defun %try-recursive-lock (lock &optional flag) 631 (let* ((self (%current-tcr))) 632 (declare (fixnum self)) 633 (if flag 634 (if (istruct-typep flag 'lock-acquisition) 635 (setf (lock-acquisition.status flag) nil) 636 (report-bad-arg flag 'lock-acquisition))) 637 (without-interrupts 638 (cond ((eql (%get-object lock target::lockptr.owner) self) 639 (incf (%get-natural lock target::lockptr.count)) 640 (if flag (setf (lock-acquisition.status flag) t)) 641 t) 642 (t 643 (when (eql 0 (%ptr-store-conditional lock futex-avail futex-locked)) 644 (%set-object lock target::lockptr.owner self) 645 (setf (%get-natural lock target::lockptr.count) 1) 646 (if flag (setf (lock-acquisition.status flag) t)) 647 t)))))) 648 649 650 651 #-futex 549 652 (defun %unlock-recursive-lock (lock) 550 653 (with-macptrs ((signal (%get-ptr lock target::lockptr.signal)) … … 571 674 nil) 572 675 676 #+futex 677 (defun %unlock-recursive-lock (lock) 678 (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr)) 679 (error 'not-lock-owner :lock lock)) 680 (without-interrupts 681 (when (eql 0 (decf (the fixnum 682 (%get-natural lock target::lockptr.count)))) 683 (setf (%get-natural lock target::lockptr.owner) 0) 684 (%unlock-futex lock))) 685 nil) 686 687 688 573 689 574 690 (defun %%lock-owner (lock) … … 616 732 (return cell)))))) 617 733 734 (defun atomic-pop-uvector-cell (v i) 735 (let* ((offset (+ target::misc-data-offset (ash i target::word-shift)))) 736 (loop 737 (let* ((old (%svref v i))) 738 (if (null old) 739 (return (values nil nil)) 740 (let* ((tail (cdr old))) 741 (when (%store-node-conditional offset v old tail) 742 (return (values (car old) t))))))))) 743 744 618 745 (defun store-gvector-conditional (index gvector old new) 619 746 (%store-node-conditional (+ target::misc-data-offset … … 640 767 (defun %atomic-incf-symbol-value (s &optional (by 1)) 641 768 (setq s (require-type s 'symbol)) 642 (let* ((binding-address (%symbol-binding-address s))) 643 (declare (fixnum binding-address)) 644 (if (zerop binding-address) 645 (%atomic-incf-node by s target::symbol.vcell-cell) 646 (%atomic-incf-node by binding-address (* 2 target::node-size))))) 647 648 (defun write-lock-rwlock (lock) 649 (let* ((context (%current-tcr))) 650 (if (eq (%svref lock target::lock.writer-cell) context) 651 (progn 652 (decf (%svref lock target::lock._value-cell)) 653 lock) 654 (loop 655 (when (%store-immediate-conditional target::lock._value lock 0 -1) 656 (setf (%svref lock target::lock.writer-cell) context) 657 (return lock)) 658 (%nanosleep 0 *ns-per-tick*))))) 659 660 661 (defun read-lock-rwlock (lock) 662 (loop 663 (when (%try-read-lock-rwlock lock) 664 (return lock)) 665 (%nanosleep 0 *ns-per-tick*))) 769 (multiple-value-bind (base offset) (%symbol-binding-address s) 770 (%atomic-incf-node by base offset))) 771 772 ;;; What happens if there are some pending readers and another writer, 773 ;;; and we abort out of the semaphore wait ? If the writer semaphore is 774 ;;; signaled before we abandon interest in it 775 #-futex 776 (defun %write-lock-rwlock-ptr (ptr &optional flag) 777 (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) ) 778 (if (istruct-typep flag 'lock-acquisition) 779 (setf (lock-acquisition.status flag) nil) 780 (if flag (report-bad-arg flag 'lock-acquisition))) 781 (let* ((level *interrupt-level*) 782 (tcr (%current-tcr))) 783 (declare (fixnum tcr)) 784 (without-interrupts 785 (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) 786 (if (eq (%get-object ptr target::rwlock.writer) tcr) 787 (progn 788 (incf (%get-signed-natural ptr target::rwlock.state)) 789 (setf (%get-natural ptr target::rwlock.spin) 0) 790 (if flag 791 (setf (lock-acquisition.status flag) t)) 792 t) 793 (do* () 794 ((eql 0 (%get-signed-natural ptr target::rwlock.state)) 795 ;; That wasn't so bad, was it ? We have the spinlock now. 796 (setf (%get-signed-natural ptr target::rwlock.state) 1 797 (%get-natural ptr target::rwlock.spin) 0) 798 (%set-object ptr target::rwlock.writer tcr) 799 (if flag 800 (setf (lock-acquisition.status flag) t)) 801 t) 802 (incf (%get-natural ptr target::rwlock.blocked-writers)) 803 (setf (%get-natural ptr target::rwlock.spin) 0) 804 (let* ((*interrupt-level* level)) 805 (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait")) 806 (%get-spin-lock ptr))))))) 807 #+futex 808 (defun %write-lock-rwlock-ptr (ptr &optional flag) 809 (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) ) 810 (if (istruct-typep flag 'lock-acquisition) 811 (setf (lock-acquisition.status flag) nil) 812 (if flag (report-bad-arg flag 'lock-acquisition))) 813 (let* ((level *interrupt-level*) 814 (tcr (%current-tcr))) 815 (declare (fixnum tcr)) 816 (without-interrupts 817 (%lock-futex ptr level) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) 818 (if (eq (%get-object ptr target::rwlock.writer) tcr) 819 (progn 820 (incf (%get-signed-natural ptr target::rwlock.state)) 821 (%unlock-futex ptr) 822 (if flag 823 (setf (lock-acquisition.status flag) t)) 824 t) 825 (do* () 826 ((eql 0 (%get-signed-natural ptr target::rwlock.state)) 827 ;; That wasn't so bad, was it ? We have the spinlock now. 828 (setf (%get-signed-natural ptr target::rwlock.state) 1) 829 (%unlock-futex ptr) 830 (%set-object ptr target::rwlock.writer tcr) 831 (if flag 832 (setf (lock-acquisition.status flag) t)) 833 t) 834 (incf (%get-natural ptr target::rwlock.blocked-writers)) 835 (let* ((waitval (%get-natural write-signal 0))) 836 (%unlock-futex ptr) 837 (let* ((*interrupt-level* level)) 838 (futex-wait write-signal waitval))) 839 (%lock-futex ptr level) 840 (decf (%get-natural ptr target::rwlock.blocked-writers)))))))) 841 842 843 844 (defun write-lock-rwlock (lock &optional flag) 845 (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag)) 846 847 #-futex 848 (defun %read-lock-rwlock-ptr (ptr lock &optional flag) 849 (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal))) 850 (if (istruct-typep flag 'lock-acquisition) 851 (setf (lock-acquisition.status flag) nil) 852 (if flag (report-bad-arg flag 'lock-acquisition))) 853 (let* ((level *interrupt-level*) 854 (tcr (%current-tcr))) 855 (declare (fixnum tcr)) 856 (without-interrupts 857 (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) 858 (if (eq (%get-object ptr target::rwlock.writer) tcr) 859 (progn 860 (setf (%get-natural ptr target::rwlock.spin) 0) 861 (error 'deadlock :lock lock)) 862 (do* ((state 863 (%get-signed-natural ptr target::rwlock.state) 864 (%get-signed-natural ptr target::rwlock.state))) 865 ((<= state 0) 866 ;; That wasn't so bad, was it ? We have the spinlock now. 867 (setf (%get-signed-natural ptr target::rwlock.state) 868 (the fixnum (1- state)) 869 (%get-natural ptr target::rwlock.spin) 0) 870 (if flag 871 (setf (lock-acquisition.status flag) t)) 872 t) 873 (declare (fixnum state)) 874 (incf (%get-natural ptr target::rwlock.blocked-readers)) 875 (setf (%get-natural ptr target::rwlock.spin) 0) 876 (let* ((*interrupt-level* level)) 877 (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait")) 878 (%get-spin-lock ptr))))))) 879 880 #+futex 881 (defun %read-lock-rwlock-ptr (ptr lock &optional flag) 882 (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))) 883 (if (istruct-typep flag 'lock-acquisition) 884 (setf (lock-acquisition.status flag) nil) 885 (if flag (report-bad-arg flag 'lock-acquisition))) 886 (let* ((level *interrupt-level*) 887 (tcr (%current-tcr))) 888 (declare (fixnum tcr)) 889 (without-interrupts 890 (%lock-futex ptr level) 891 (if (eq (%get-object ptr target::rwlock.writer) tcr) 892 (progn 893 (%unlock-futex ptr) 894 (error 'deadlock :lock lock)) 895 (do* ((state 896 (%get-signed-natural ptr target::rwlock.state) 897 (%get-signed-natural ptr target::rwlock.state))) 898 ((<= state 0) 899 ;; That wasn't so bad, was it ? We have the spinlock now. 900 (setf (%get-signed-natural ptr target::rwlock.state) 901 (the fixnum (1- state))) 902 (%unlock-futex ptr) 903 (if flag 904 (setf (lock-acquisition.status flag) t)) 905 t) 906 (declare (fixnum state)) 907 (incf (%get-natural ptr target::rwlock.blocked-readers)) 908 (let* ((waitval (%get-natural reader-signal 0))) 909 (%unlock-futex ptr) 910 (let* ((*interrupt-level* level)) 911 (futex-wait reader-signal waitval))) 912 (%lock-futex ptr level) 913 (decf (%get-natural ptr target::rwlock.blocked-readers)))))))) 914 915 916 917 (defun read-lock-rwlock (lock &optional flag) 918 (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) 919 920 ;;; If the current thread already owns the lock for writing, increment 921 ;;; the lock's state. Otherwise, try to lock the lock for reading. 922 (defun %ensure-at-least-read-locked (lock &optional flag) 923 (if (istruct-typep flag 'lock-acquisition) 924 (setf (lock-acquisition.status flag) nil) 925 (if flag (report-bad-arg flag 'lock-acquisition))) 926 (let* ((ptr (read-write-lock-ptr lock)) 927 (tcr (%current-tcr)) 928 #+futex (level *interrupt-level*)) 929 (declare (fixnum tcr)) 930 (or 931 (without-interrupts 932 #+futex 933 (%lock-futex ptr level) 934 #-futex 935 (%get-spin-lock ptr) 936 (let* ((state (%get-signed-natural ptr target::rwlock.state))) 937 (declare (fixnum state)) 938 (let ((win 939 (cond ((<= state 0) 940 (setf (%get-signed-natural ptr target::rwlock.state) 941 (the fixnum (1- state))) 942 t) 943 ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr) 944 (setf (%get-signed-natural ptr target::rwlock.state) 945 (the fixnum (1+ state))) 946 t)))) 947 #+futex 948 (%unlock-futex ptr) 949 #-futex 950 (setf (%get-natural ptr target::rwlock.spin) 0) 951 (when win 952 (if flag 953 (setf (lock-acquisition.status flag) t)) 954 t)))) 955 (%read-lock-rwlock-ptr ptr lock flag)))) 956 957 #-futex 958 (defun %unlock-rwlock-ptr (ptr lock) 959 (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal)) 960 (writer-signal (%get-ptr ptr target::rwlock.writer-signal))) 961 (without-interrupts 962 (%get-spin-lock ptr) 963 (let* ((state (%get-signed-natural ptr target::rwlock.state)) 964 (tcr (%current-tcr))) 965 (declare (fixnum state tcr)) 966 (cond ((> state 0) 967 (unless (eql tcr (%get-object ptr target::rwlock.writer)) 968 (setf (%get-natural ptr target::rwlock.spin) 0) 969 (error 'not-lock-owner :lock lock)) 970 (decf state)) 971 ((< state 0) (incf state)) 972 (t (setf (%get-natural ptr target::rwlock.spin) 0) 973 (error 'not-locked :lock lock))) 974 (setf (%get-signed-natural ptr target::rwlock.state) state) 975 (when (zerop state) 976 ;; We want any thread waiting for a lock semaphore to 977 ;; be able to wait interruptibly. When a thread waits, 978 ;; it increments either the "blocked-readers" or "blocked-writers" 979 ;; field, but since it may get interrupted before obtaining 980 ;; the semaphore that's more of "an expression of interest" 981 ;; in taking the lock than it is "a firm commitment to take it." 982 ;; It's generally (much) better to signal the semaphore(s) 983 ;; too often than it would be to not signal them often 984 ;; enough; spurious wakeups are better than deadlock. 985 ;; So: if there are blocked writers, the writer-signal 986 ;; is raised once for each apparent blocked writer. (At most 987 ;; one writer will actually succeed in taking the lock.) 988 ;; If there are blocked readers, the reader-signal is raised 989 ;; once for each of them. (It's possible for both the 990 ;; reader and writer semaphores to be raised on the same 991 ;; unlock; the writer semaphore is raised first, so in that 992 ;; sense, writers still have priority but it's not guaranteed.) 993 ;; Both the "blocked-writers" and "blocked-readers" fields 994 ;; are cleared here (they can't be changed from another thread 995 ;; until this thread releases the spinlock.) 996 (setf (%get-signed-natural ptr target::rwlock.writer) 0) 997 (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) 998 (nreaders (%get-natural ptr target::rwlock.blocked-readers))) 999 (declare (fixnum nreaders nwriters)) 1000 (when (> nwriters 0) 1001 (setf (%get-natural ptr target::rwlock.blocked-writers) 0) 1002 (dotimes (i nwriters) 1003 (%signal-semaphore-ptr writer-signal))) 1004 (when (> nreaders 0) 1005 (setf (%get-natural ptr target::rwlock.blocked-readers) 0) 1006 (dotimes (i nreaders) 1007 (%signal-semaphore-ptr reader-signal))))) 1008 (setf (%get-natural ptr target::rwlock.spin) 0) 1009 t)))) 1010 1011 #+futex 1012 (defun %unlock-rwlock-ptr (ptr lock) 1013 (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)) 1014 (writer-signal (%INC-ptr ptr target::rwlock.writer-signal))) 1015 (let* ((signal nil) 1016 (wakeup 0)) 1017 (without-interrupts 1018 (%lock-futex ptr -1) 1019 (let* ((state (%get-signed-natural ptr target::rwlock.state)) 1020 (tcr (%current-tcr))) 1021 (declare (fixnum state tcr)) 1022 (cond ((> state 0) 1023 (unless (eql tcr (%get-object ptr target::rwlock.writer)) 1024 (%unlock-futex ptr) 1025 (error 'not-lock-owner :lock lock)) 1026 (decf state)) 1027 ((< state 0) (incf state)) 1028 (t (%unlock-futex ptr) 1029 (error 'not-locked :lock lock))) 1030 (setf (%get-signed-natural ptr target::rwlock.state) state) 1031 (when (zerop state) 1032 (setf (%get-signed-natural ptr target::rwlock.writer) 0) 1033 (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) 1034 (nreaders (%get-natural ptr target::rwlock.blocked-readers))) 1035 (declare (fixnum nreaders nwriters)) 1036 (if (> nwriters 0) 1037 (setq signal writer-signal wakeup 1) 1038 (if (> nreaders 0) 1039 (setq signal reader-signal wakeup #$INT_MAX))))) 1040 (when signal (incf (%get-signed-natural signal 0))) 1041 (%unlock-futex ptr) 1042 (when signal (futex-wake signal wakeup)) 1043 t))))) 1044 1045 1046 (defun unlock-rwlock (lock) 1047 (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock)) 1048 1049 ;;; There are all kinds of ways to lose here. 1050 ;;; The caller must have read access to the lock exactly once, 1051 ;;; or have write access. 1052 ;;; there's currently no way to detect whether the caller has 1053 ;;; read access at all. 1054 ;;; If we have to block and get interrupted, cleanup code may 1055 ;;; try to unlock a lock that we don't hold. (It might be possible 1056 ;;; to circumvent that if we use the same notifcation object here 1057 ;;; that controls that cleanup process.) 1058 1059 (defun %promote-rwlock (lock &optional flag) 1060 (let* ((ptr (read-write-lock-ptr lock))) 1061 (if (istruct-typep flag 'lock-acquisition) 1062 (setf (lock-acquisition.status flag) nil) 1063 (if flag (report-bad-arg flag 'lock-acquisition))) 1064 (let* ((level *interrupt-level*) 1065 (tcr (%current-tcr))) 1066 (without-interrupts 1067 #+futex 1068 (%lock-futex ptr level) 1069 #-futex 1070 (%get-spin-lock ptr) 1071 (let* ((state (%get-signed-natural ptr target::rwlock.state))) 1072 (declare (fixnum state)) 1073 (cond ((> state 0) 1074 (unless (eql (%get-object ptr target::rwlock.writer) tcr) 1075 #+futex 1076 (%unlock-futex ptr) 1077 #-futex 1078 (setf (%get-natural ptr target::rwlock.spin) 0) 1079 (error :not-lock-owner :lock lock))) 1080 ((= state 0) 1081 #+futex (%unlock-futex ptr) 1082 #-futex (setf (%get-natural ptr target::rwlock.spin) 0) 1083 (error :not-locked :lock lock)) 1084 (t 1085 (if (= state -1) 1086 (progn 1087 (setf (%get-signed-natural ptr target::rwlock.state) 1) 1088 (%set-object ptr target::rwlock.writer tcr) 1089 #+futex 1090 (%unlock-futex ptr) 1091 #-futex 1092 (setf (%get-natural ptr target::rwlock.spin) 0) 1093 (if flag 1094 (setf (lock-acquisition.status flag) t)) 1095 t) 1096 (progn 1097 (%unlock-rwlock-ptr ptr lock) 1098 (let* ((*interrupt-level* level)) 1099 (%write-lock-rwlock-ptr ptr flag))))))))))) 1100 1101 666 1102 667 1103 (defun safe-get-ptr (p &optional dest) -
branches/working-0711/ccl/level-0/l0-numbers.lisp
r7354 r7624 1726 1726 1727 1727 1728 #+32-bit-target 1728 1729 (defun random (number &optional (state *random-state*)) 1729 1730 (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) … … 1733 1734 (if (< number 65536) 1734 1735 (fast-mod (%next-random-seed state) number) 1735 (%bignum-random number state)))) 1736 (let* ((n 0) 1737 (nhalf (ash (+ 15 (integer-length number)) -4))) 1738 (declare (fixnum n nhalf)) 1739 (dotimes (i nhalf (fast-mod n number)) 1740 (setq n (logior (the fixnum (ash n 16)) 1741 (the fixnum (%next-random-seed state))))))))) 1736 1742 ((and (typep number 'double-float) (> (the double-float number) 0.0)) 1737 1743 (%float-random number state)) … … 1742 1748 (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) 1743 1749 1750 #+64-bit-target 1751 (defun random (number &optional (state *random-state*)) 1752 (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) 1753 (cond 1754 ((and (fixnump number) (> (the fixnum number) 0)) 1755 (locally (declare (fixnum number)) 1756 (let* ((n 0) 1757 (n32 (ash (+ 31 (integer-length number)) -5))) 1758 (declare (fixnum n n32)) 1759 (dotimes (i n32 (fast-mod n number)) 1760 (setq n (logior (the fixnum (ash n 32)) 1761 (the fixnum (%next-random-seed state)))))))) 1762 ((and (typep number 'double-float) (> (the double-float number) 0.0)) 1763 (%float-random number state)) 1764 ((and (typep number 'short-float) (> (the short-float number) 0.0s0)) 1765 (%float-random number state)) 1766 ((and (bignump number) (> number 0)) 1767 (%bignum-random number state)) 1768 (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) 1769 1744 1770 1745 1771 #| … … 1784 1810 1785 1811 #+64-bit-target 1786 (defun %next-random-pair (high low) 1787 (declare (type (unsigned-byte 16) high low)) 1788 (let* ((n0 1789 (%i* 48271 1790 (the (unsigned-byte 31) 1791 (logior (the (unsigned-byte 31) 1792 (ash (ldb (byte 15 0) high) 16)) 1793 (the (unsigned-byte 16) 1794 (ldb (byte 16 0) low)))))) 1795 (n (fast-mod n0 (1- (expt 2 31))))) 1812 (defun %next-random-seed (state) 1813 (let* ((n (the fixnum (* (the fixnum (random.seed-1 state)) 48271)))) 1796 1814 (declare (fixnum n)) 1797 (values (ldb (byte 15 16) n) 1798 (ldb (byte 16 0) n)))) 1799 1815 (setf (random.seed-1 state) (fast-mod n (1- (expt 2 31)))) 1816 (logand n (1- (ash 1 32))))) 1817 1818 #+32-bit-target 1800 1819 (defun %next-random-seed (state) 1801 (multiple-value-bind (high low) (%next-random-pair ( %svref state 1)1802 ( %svref state 2))1820 (multiple-value-bind (high low) (%next-random-pair (random.seed-1 state) 1821 (random.seed-2 state)) 1803 1822 (declare (type (unsigned-byte 15) high) 1804 1823 (type (unsigned-byte 16) low)) 1805 (setf ( %svref state 1) high1806 ( %svref state 2) low)1824 (setf (random.seed-1 state) high 1825 (random.seed-2 state) low) 1807 1826 (logior high (the fixnum (logand low (ash 1 15)))))) 1808 1827 1809 1828 #+32-bit-target 1810 1829 (defun %bignum-random (number state) 1811 1830 (let* ((bits (+ (integer-length number) 8)) … … 1836 1855 1837 1856 (defun %float-random (number state) 1838 (if (zerop number) 1839 number 1840 (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum))) 1841 (declare (dynamic-extent ratio)) 1842 (* number ratio)))) 1857 (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum))) 1858 (declare (dynamic-extent ratio)) 1859 (* number ratio))) 1843 1860 1844 1861 (eval-when (:compile-toplevel :execute) -
branches/working-0711/ccl/level-0/l0-pred.lisp
r7578 r7624 401 401 catch-frame ; 4 402 402 function ; 5 403 lisp-thread; 6403 basic-stream ; 6 404 404 symbol ; 7 405 405 lock ; 8 … … 586 586 ratio 587 587 symbol 588 lisp-thread588 basic-stream 589 589 standard-instance 590 590 complex … … 703 703 package 704 704 slot-vector 705 lisp-thread705 basic-stream 706 706 function-vector ;8 707 707 array-header -
branches/working-0711/ccl/level-0/l0-utils.lisp
r6916 r7624 107 107 (assq item list))) 108 108 109 (defun assequal (item list) 110 (dolist (pair list) 111 (if pair 112 (if (equal item (car pair)) 113 (return pair))))) 114 115 109 116 ;;; (memeql item list) <=> (member item list :test #'eql :key #'identity) 110 117 (defun memeql (item list) … … 113 120 ((endp l)) 114 121 (when (eql (%car l) item) (return l))) 115 (memq item list)) 116 ) 122 (memq item list))) 123 124 (defun memequal (item list) 125 (do* ((l list (%cdr l))) 126 ((endp l)) 127 (when (equal (%car l) item) (return l)))) 117 128 118 129 -
branches/working-0711/ccl/level-0/nfasload.lisp
r6184 r7624 1045 1045 *xload-startup-file*)) 1046 1046 (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot. 1047 1047 (setq %system-locks% (%cons-population nil)) 1048 1048 ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually 1049 1049 ;; do SET-PACKAGE in cold load functions. -
branches/working-0711/ccl/level-1/l1-aprims.lisp
r7463 r7624 1861 1861 (gethash lower *non-standard-lower-to-upper*) upper))) 1862 1862 1863 (assert-hash-table-readonly *non-standard-upper-to-lower*) 1864 (assert-hash-table-readonly *non-standard-lower-to-upper*) 1865 1863 1866 (defun %non-standard-upper-case-equivalent (char) 1864 1867 (gethash char *non-standard-lower-to-upper*)) -
branches/working-0711/ccl/level-1/l1-boot-2.lisp
r6186 r7624 269 269 (bin-load-provide "MCL-COMPAT" "mcl-compat") 270 270 (require "LOOP") 271 (require "HASH-CONS")272 271 (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms") 273 272 (l1-load-provide "VERSION" "version") -
branches/working-0711/ccl/level-1/l1-clos.lisp
r5944 r7624 1738 1738 newval)))))))))) 1739 1739 instance) 1740 1741 ;;; Sometimes you can do a lot better at generic function dispatch than the 1742 ;;; default. This supports that for the one-arg-dcode case. 1743 (defmethod override-one-method-one-arg-dcode ((generic-function t) (method t)) 1744 nil) 1745 1746 (defun optimize-generic-function-dispatching () 1747 (dolist (gf (population.data %all-gfs%)) 1748 (when (eq #'%%one-arg-dcode (%gf-dcode gf)) 1749 (let ((methods (generic-function-methods gf))) 1750 (when (eql 1 (length methods)) 1751 (override-one-method-one-arg-dcode gf (car methods))))))) 1752 1753 1754 1755 ;;; dcode for a GF with a single reader method which accesses 1756 ;;; a slot in a class that has no subclasses (that restriction 1757 ;;; makes typechecking simpler and also ensures that the slot's 1758 ;;; location is correct.) 1759 (defun singleton-reader-dcode (dt instance) 1760 (declare (optimize (speed 3) (safety 0))) 1761 (let* ((class (%svref dt %gf-dispatch-table-first-data)) 1762 (location (%svref dt (1+ %gf-dispatch-table-first-data)))) 1763 (if (eq (if (eq (typecode instance) target::subtag-instance) 1764 (%class-of-instance instance)) 1765 class) 1766 (%slot-ref (instance.slots instance) location) 1767 (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) 1768 1769 ;;; Dcode for a GF whose methods are all reader-methods which access a 1770 ;;; slot in one or more classes which have multiple subclasses, all of 1771 ;;; which (by luck or design) have the same slot-definition location. 1772 (defun reader-constant-location-dcode (dt instance) 1773 (declare (optimize (speed 3) (safety 0))) 1774 (let* ((classes (%svref dt %gf-dispatch-table-first-data)) 1775 (location (%svref dt (1+ %gf-dispatch-table-first-data)))) 1776 (if (memq (if (eq (typecode instance) target::subtag-instance) 1777 (%class-of-instance instance)) 1778 classes) 1779 (%slot-ref (instance.slots instance) location) 1780 (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) 1781 1782 ;;; Similar to the case above, but we use an alist to map classes 1783 ;;; to their non-constant locations. 1784 (defun reader-variable-location-dcode (dt instance) 1785 (declare (optimize (speed 3) (safety 0))) 1786 (let* ((alist (%svref dt %gf-dispatch-table-first-data)) 1787 (location (cdr 1788 (assq 1789 (if (eq (typecode instance) target::subtag-instance) 1790 (%class-of-instance instance)) 1791 alist)))) 1792 (if location 1793 (%slot-ref (instance.slots instance) location) 1794 (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) 1795 1796 (defun class-and-slot-location-alist (classes slot-name) 1797 (let* ((alist nil)) 1798 (labels ((add-class (c) 1799 (unless (assq c alist) 1800 (let* ((slots (class-slots c))) 1801 (unless slots 1802 (finalize-inheritance c) 1803 (setq slots (class-slots c))) 1804 (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist)) 1805 (dolist (sub (class-direct-subclasses c)) 1806 (add-class sub))))) 1807 (dolist (class classes) (add-class class)) 1808 ;; Building the alist the way that we have should often approximate 1809 ;; this ordering; the idea is that leaf classes are more likely to 1810 ;; be instantiated than non-leaves. 1811 (sort alist (lambda (c1 c2) 1812 (< (length (class-direct-subclasses c1)) 1813 (length (class-direct-subclasses c2)))) 1814 :key #'car)))) 1815 1816 1817 ;;; Try to replace gf dispatch with something faster in f. 1818 (defun %snap-reader-method (f) 1819 (when (slot-boundp f 'methods) 1820 (let* ((methods (generic-function-methods f))) 1821 (when (and methods 1822 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods) 1823 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods) 1824 (every (lambda (m) (null (method-qualifiers m))) methods)) 1825 (let* ((m0 (car methods)) 1826 (name (slot-definition-name (accessor-method-slot-definition m0)))) 1827 (when (every (lambda (m) 1828 (eq name (slot-definition-name (accessor-method-slot-definition m)))) 1829 (cdr methods)) 1830 ;; All methods are *STANDARD-READER-METHODS* that 1831 ;; access the same slot name. Build an alist of 1832 ;; mapping all subclasses of all classes on which those 1833 ;; methods are specialized to the effective slot's 1834 ;; location in that subclass. 1835 (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m))) 1836 methods)) 1837 (alist (class-and-slot-location-alist classes name)) 1838 (loc (cdar alist)) 1839 (dt (gf.dispatch-table f))) 1840 ;; Only try to handle the case where all slots have 1841 ;; :allocation :instance (and all locations - the CDRs 1842 ;; of the alist pairs - are small, positive fixnums. 1843 (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist) 1844 (clear-gf-dispatch-table dt) 1845 (cond ((null (cdr alist)) 1846 ;; Method is only applicable to a single class. 1847 (destructuring-bind (class . location) (car alist) 1848 (setf (%svref dt %gf-dispatch-table-first-data) class 1849 (%svref dt (1+ %gf-dispatch-table-first-data)) location 1850 (gf.dcode f) #'singleton-reader-dcode))) 1851 ((dolist (other (cdr alist) t) 1852 (unless (eq (cdr other) loc) 1853 (return))) 1854 ;; All classes have the slot in the same location, 1855 ;; by luck or design. 1856 (setf (%svref dt %gf-dispatch-table-first-data) 1857 (mapcar #'car alist) 1858 (%svref dt (1+ %gf-dispatch-table-first-data)) 1859 loc 1860 (gf.dcode f) #'reader-constant-location-dcode)) 1861 (t 1862 ;; Multiple classes; the slot's location varies. 1863 (setf (%svref dt %gf-dispatch-table-first-data) 1864 alist 1865 1866 (gf.dcode f) #'reader-variable-location-dcode))))))))))) 1867 1868 1869 ;;; Iterate over all known GFs; try to optimize their dcode in cases 1870 ;;; involving reader methods. 1871 1872 (defun snap-reader-methods (&key known-sealed-world (check-conflicts t)) 1873 (declare (ignore check-conflicts)) 1874 (unless known-sealed-world 1875 (cerror "Proceed, if it's known that no new classes or methods will be defined." 1876 "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined.")) 1877 (let* ((ngf 0) 1878 (nwin 0)) 1879 (dolist (f (population.data %all-gfs%)) 1880 (incf ngf) 1881 (when (%snap-reader-method f) 1882 (incf nwin))) 1883 (values ngf nwin 0))) -
branches/working-0711/ccl/level-1/l1-error-system.lisp
r7126 r7624 262 262 (format s "Current process ~s does not own lock ~s" 263 263 *current-process* (slot-value c 'lock))))) 264 265 (define-condition not-locked (lock-protocol-error) 266 () 267 (:report (lambda (c s) 268 (format s "Lock ~s isn't locked." (slot-value c 'lock))))) 269 270 (define-condition deadlock (lock-protocol-error) 271 () 272 (:report (lambda (c s) 273 (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock))))) 264 274 265 275 (define-condition package-error (error) … … 576 586 "Make an instance of a condition object using the specified initargs." 577 587 (declare (dynamic-extent init-list)) 578 (let ((class (or (and (symbolp name) (find-class name nil)) 579 name))) 580 (if (condition-p (class-prototype class)) 581 (apply #'make-instance class init-list) 582 (error "~S is not a defined condition type name" name)))) 588 (if (subtypep name 'condition) 589 (apply #'make-instance name init-list) 590 (error "~S is not a defined condition type name" name))) 583 591 584 592 (defmethod print-object ((c condition) stream) -
branches/working-0711/ccl/level-1/l1-lisp-threads.lisp
r7610 r7624 303 303 304 304 305 (defmacro with-self-bound-io-control-vars (&body body) 306 `(let (; from CLtL2, table 22-7: 307 (*package* *package*) 308 (*print-array* *print-array*) 309 (*print-base* *print-base*) 310 (*print-case* *print-case*) 311 (*print-circle* *print-circle*) 312 (*print-escape* *print-escape*) 313 (*print-gensym* *print-gensym*) 314 (*print-length* *print-length*) 315 (*print-level* *print-level*) 316 (*print-lines* *print-lines*) 317 (*print-miser-width* *print-miser-width*) 318 (*print-pprint-dispatch* *print-pprint-dispatch*) 319 (*print-pretty* *print-pretty*) 320 (*print-radix* *print-radix*) 321 (*print-readably* *print-readably*) 322 (*print-right-margin* *print-right-margin*) 323 (*read-base* *read-base*) 324 (*read-default-float-format* *read-default-float-format*) 325 (*read-eval* *read-eval*) 326 (*read-suppress* *read-suppress*) 327 (*readtable* *readtable*)) 328 ,@body)) 305 329 306 330 307 … … 964 941 965 942 966 (def var*termination-population*943 (defstatic *termination-population* 967 944 (%cons-terminatable-alist)) 968 945 969 (def var*termination-population-lock* (make-lock))946 (defstatic *termination-population-lock* (make-lock)) 970 947 971 948 … … 980 957 or releasing of resources which needs to happen when a certain object is 981 958 no longer being used." 982 (let ((new-cell ( list (cons object function)))959 (let ((new-cell (cons object function)) 983 960 (population *termination-population*)) 984 961 (without-interrupts 985 962 (with-lock-grabbed (*termination-population-lock*) 986 (setf (cdr new-cell) (population-data population) 987 (population-data population) new-cell))) 963 (atomic-push-uvector-cell population population.data new-cell))) 988 964 function)) 989 965 … … 992 968 993 969 (defun drain-termination-queue () 994 (let ((cell nil) 995 (population *termination-population*)) 996 (loop 997 (without-interrupts 998 (with-lock-grabbed (*termination-population-lock*) 999 (without-gcing 1000 (let ((list (population-termination-list population))) 1001 (unless list (return)) 1002 (setf cell (car list) 1003 (population-termination-list population) (cdr list)))))) 1004 (funcall (cdr cell) (car cell))))) 970 (with-lock-grabbed (*termination-population-lock*) 971 (let* ((population *termination-population*)) 972 (loop 973 (multiple-value-bind (cell existed) 974 (atomic-pop-uvector-cell population population.termination-list) 975 (if (not existed) 976 (return) 977 (funcall (cdr cell) (car cell)))))))) 1005 978 1006 979 (defun cancel-terminate-when-unreachable (object &optional (function nil function-p)) 1007 (let ((found-it? nil)) 1008 (flet ((test (object cell) 1009 (and (eq object (car cell)) 1010 (or (not function-p) 1011 (eq function (cdr cell))) 1012 (setq found-it? t)))) 1013 (declare (dynamic-extent #'test)) 1014 (without-interrupts 1015 (with-lock-grabbed (*termination-population-lock*) 1016 (setf (population-data *termination-population*) 1017 (delete object (population-data *termination-population*) 1018 :test #'test 1019 :count 1)))) 1020 found-it?))) 980 (let* ((found nil)) 981 (with-lock-grabbed (*termination-population-lock*) 982 ;; Have to defer GCing, e.g., defer responding to a GC 983 ;; suspend request here (that also defers interrupts) 984 ;; We absolutely, positively can't take an exception 985 ;; in here, so don't even bother to typecheck on 986 ;; car/cdr etc. 987 (with-deferred-gc 988 (do ((spine (population-data *termination-population*) (cdr spine)) 989 (prev nil spine)) 990 ((null spine)) 991 (declare (optimize (speed 3) (safety 0))) 992 (let* ((head (car spine)) 993 (tail (cdr spine)) 994 (o (car head)) 995 (f (cdr head))) 996 (when (and (eq o object) 997 (or (null function-p) 998 (eq function f))) 999 (if prev 1000 (setf (cdr prev) tail) 1001 (setf (population-data *termination-population*) tail)) 1002 (setq found t) 1003 (return))))) 1004 found))) 1005 1021 1006 1022 1007 (defun termination-function (object) -
branches/working-0711/ccl/level-1/l1-numbers.lisp
r6027 r7624 421 421 nil))) 422 422 423 (defun %cons-random-state (seed-1 seed-2) 424 #+32-bit-target 425 (gvector :istuct 426 'random-state 427 seed-1 428 seed-2) 429 #+64-bit-target 430 (gvector :istruct 431 'random-state 432 (the fixnum (+ (the fixnum seed-2) 433 (the fixnum (ash (the fixnum seed-1) 16)))))) 434 423 435 ;;; random associated stuff except for the print-object method which 424 436 ;;; is still in "lib;numbers.lisp" … … 428 440 (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000)) 429 441 (report-bad-arg seed-2 '(unsigned-byte 16))) 430 (gvector :istruct 431 'random-state 432 seed-1 433 seed-2)) 434 435 436 437 442 (%cons-random-state seed-1 seed-2)) 438 443 439 444 (defun make-random-state (&optional state) … … 449 454 (setq state (require-type (or state *random-state*) 'random-state)) 450 455 (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state)))) 451 ( gvector :istruct 'random-state seed-1 seed-2)))456 (%cons-random-state seed-1 seed-2))) 452 457 453 458 (defun random-state-p (thing) (istruct-typep thing 'random-state)) -
branches/working-0711/ccl/level-1/l1-readloop-lds.lisp
r7225 r7624 152 152 (if frame-sp 153 153 (toplevel-print (list (nth-value-in-frame frame-sp n nil)))))) 154 155 (define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>" 156 (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) 157 (when frame-sp 158 (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) 159 (when (and lfun pc) 160 (let* ((unavailable (cons nil nil))) 161 (declare (dynamic-extent unavailable)) 162 (let* ((value (arg-value nil frame-sp lfun pc unavailable name))) 163 (if (eq value unavailable) 164 (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) 165 (toplevel-print (list value)))))))))) 166 167 (define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>." 168 (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) 169 (when frame-sp 170 (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) 171 (when (and lfun pc) 172 (or (set-arg-value nil frame-sp lfun pc name new) 173 (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) 174 175 176 (define-toplevel-command :break local (name frame-number) "Return value of local denoted by <name> in frame <frame-number> <name> can either be a symbol - in which case the most recent 177 binding of that symbol is used - or an integer index into the frame's set of local bindings." 178 (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) 179 (when frame-sp 180 (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) 181 (when (and lfun pc) 182 (let* ((unavailable (cons nil nil))) 183 (declare (dynamic-extent unavailable)) 184 (let* ((value (local-value nil frame-sp lfun pc unavailable name))) 185 (if (eq value unavailable) 186 (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) 187 (toplevel-print (list value)))))))))) 188 189 (define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted <name> (see :LOCAL) in frame <frame-number> to value <new>." 190 (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) 191 (when frame-sp 192 (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) 193 (when (and lfun pc) 194 (or (set-local-value nil frame-sp lfun pc name new) 195 (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) 196 154 197 155 198 (define-toplevel-command :break form (frame-number) … … 272 315 (cons keyword params) 273 316 keyword))) 274 (params param)))))))))))317 (params (eval param)))))))))))) 275 318 276 319 ;;; Read a form from the specified stream. … … 349 392 (dolist (x bogus-globals) 350 393 (set x (funcall (pop newvals)))) 351 (when (and *debugger-hook* *break-on-errors* )394 (when (and *debugger-hook* *break-on-errors* (not *batch-flag*)) 352 395 (let ((hook *debugger-hook*) 353 396 (*debugger-hook* nil)) … … 363 406 (format s "~s" oldval)) 364 407 (format s ", was reset to ~s ." (symbol-value bogusness))))) 365 (if *break-on-errors*408 (if (and *break-on-errors* (not *batch-flag*)) 366 409 (break-loop condition error-pointer) 367 (abort))))) 410 (if *batch-flag* 411 (quit -1) 412 (abort)))))) 368 413 369 414 (defun break (&optional string &rest args) -
branches/working-0711/ccl/level-1/l1-sockets.lisp
r6914 r7624 148 148 "WITH-OPEN-SOCKET")) 149 149 150 (eval-when (:compile-toplevel )150 (eval-when (:compile-toplevel :execute) 151 151 #+linuxppc-target 152 152 (require "PPC-LINUX-SYSCALLS") … … 168 168 (define-condition socket-creation-error (simple-error) 169 169 ((code :initarg :code :reader socket-creation-error-code) 170 (identifier :initform :unknown :initarg :identifier :reader socket-creation g-error-identifier)170 (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier) 171 171 (situation :initarg :situation :reader socket-creation-error-situation))) 172 172 … … 603 603 local-port local-host backlog class out-of-band-inline 604 604 local-filename remote-filename sharing basic 605 external-format )605 external-format (auto-close t)) 606 606 "Create and return a new socket." 607 607 (declare (dynamic-extent keys)) … … 609 609 keepalive reuse-address nodelay broadcast linger 610 610 local-port local-host backlog class out-of-band-inline 611 local-filename remote-filename sharing basic external-format)) 611 local-filename remote-filename sharing basic external-format 612 auto-close)) 612 613 (ecase address-family 613 614 ((:file) (apply #'make-file-socket keys)) … … 696 697 697 698 698 (defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) &allow-other-keys)699 (defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) &allow-other-keys) 699 700 (let* ((external-format (normalize-external-format :socket external-format))) 700 701 (let ((element-type (ecase format … … 711 712 :encoding (external-format-character-encoding external-format) 712 713 :line-termination (external-format-line-termination external-format) 713 :basic basic)))) 714 715 (defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream) sharing basic &allow-other-keys) 714 :basic basic 715 :auto-close auto-close)))) 716 717 (defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream) sharing basic (auto-close t) &allow-other-keys) 716 718 (let* ((external-format (normalize-external-format :socket external-format))) 717 719 … … 729 731 :sharing sharing 730 732 :character-p (not (eq format :binary)) 731 :basic basic)))) 733 :basic basic 734 :auto-close auto-close)))) 732 735 733 736 (defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys) … … 1104 1107 (pref addr :in_addr.s_addr)))))) 1105 1108 1106 (defun c_socket (domain type protocol)1109 (defun c_socket_1 (domain type protocol) 1107 1110 #-linuxppc-target 1108 1111 (syscall syscalls::socket domain type protocol) … … 1113 1116 (paref params (:* :unsigned-long) 2) protocol) 1114 1117 (syscall syscalls::socketcall 1 params))) 1118 1119 (defun c_socket (domain type protocol) 1120 (let* ((fd (c_socket_1 domain type protocol))) 1121 (when (or (eql fd (- #$EMFILE)) 1122 (eql fd (- #$ENFILE))) 1123 (gc) 1124 (drain-termination-queue) 1125 (setq fd (c_socket_1 domain type protocol))) 1126 fd)) 1127 1115 1128 1116 1129 (defun init-unix-sockaddr (addr path) -
branches/working-0711/ccl/level-1/l1-streams.lisp
r7444 r7624 3257 3257 3258 3258 3259 3259 (defun optimal-buffer-size (fd) 3260 (or (nth-value 6 (%fstat fd)) *elements-per-buffer*)) 3261 3260 3262 3261 3263 ;;; Note that we can get "bivalent" streams by specifiying :character-p t … … 3264 3266 (direction :input) 3265 3267 (interactive t) 3266 (elements-per-buffer *elements-per-buffer*)3268 (elements-per-buffer (optimal-buffer-size fd)) 3267 3269 (element-type 'character) 3268 3270 (class 'fd-stream) … … 3272 3274 (basic nil) 3273 3275 encoding 3274 line-termination) 3276 line-termination 3277 auto-close) 3275 3278 (when line-termination 3276 3279 (setq line-termination … … 3282 3285 (out-p (member direction '(:io :output))) 3283 3286 (class-name (select-stream-class class in-p out-p character-p)) 3284 (class (find-class class-name))) 3285 (make-ioblock-stream class 3286 :insize (if in-p elements-per-buffer) 3287 :outsize (if out-p elements-per-buffer) 3288 :device fd 3289 :interactive interactive 3290 :element-type element-type 3291 :advance-function (if in-p 3292 (select-stream-advance-function class direction)) 3293 :listen-function (if in-p 'fd-stream-listen) 3294 :eofp-function (if in-p 'fd-stream-eofp) 3295 :force-output-function (if out-p 3296 (select-stream-force-output-function class direction)) 3297 :close-function 'fd-stream-close 3298 :sharing sharing 3299 :character-p character-p 3300 :encoding encoding 3301 :line-termination line-termination))) 3287 (class (find-class class-name)) 3288 (stream 3289 (make-ioblock-stream class 3290 :insize (if in-p elements-per-buffer) 3291 :outsize (if out-p elements-per-buffer) 3292 :device fd 3293 :interactive interactive 3294 :element-type element-type 3295 :advance-function (if in-p 3296 (select-stream-advance-function class direction)) 3297 :listen-function (if in-p 'fd-stream-listen) 3298 :eofp-function (if in-p 'fd-stream-eofp) 3299 :force-output-function (if out-p 3300 (select-stream-force-output-function class direction)) 3301 :close-function 'fd-stream-close 3302 :sharing sharing 3303 :character-p character-p 3304 :encoding encoding 3305 :line-termination line-termination))) 3306 (if auto-close 3307 (terminate-when-unreachable stream 3308 (lambda (stream) 3309 (close stream :abort t)))) 3310 stream)) 3311 3302 3312 3303 3313 ;;; Fundamental streams. … … 3593 3603 s)) 3594 3604 3595 (defmethod %stream-ioblock ((s basic-stream)) 3596 (basic-stream.state s)) 3605 3597 3606 3598 3607 (defmethod (setf stream-ioblock) (ioblock (s basic-stream)) … … 4639 4648 4640 4649 (defun stream-ioblock (stream error-if-nil) 4641 (or (%stream-ioblock stream) 4650 (or (if (typep stream 'basic-stream) 4651 (basic-stream.state stream) 4652 (%stream-ioblock stream)) 4642 4653 (when error-if-nil 4643 4654 (stream-is-closed stream)))) … … 4749 4760 4750 4761 (defmethod stream-surrounding-characters ((stream basic-character-input-stream)) 4751 (let* ((ioblock ( stream-ioblock stream nil)))4762 (let* ((ioblock (basic-stream.state stream))) 4752 4763 (and ioblock (%ioblock-surrounding-characters ioblock)))) 4753 4764 … … 5361 5372 5362 5373 (defun fd-stream-close (s ioblock) 5374 (cancel-terminate-when-unreachable s) 5363 5375 (when (ioblock-dirty ioblock) 5364 5376 (stream-finish-output s)) … … 5718 5730 5719 5731 (defmethod stream-external-format ((s basic-character-stream)) 5720 (%ioblock-external-format ( stream-ioblock s t)))5732 (%ioblock-external-format (basic-stream-ioblock s))) 5721 5733 5722 5734 (defmethod (setf stream-external-format) (new (s basic-character-stream)) 5723 (setf (%ioblock-external-format ( stream-ioblock s t))5735 (setf (%ioblock-external-format (basic-stream-ioblock s)) 5724 5736 (normalize-external-format (stream-domain s) new))) 5725 5737 -
branches/working-0711/ccl/level-1/l1-unicode.lisp
r7307 r7624 2862 2862 (setf (schar string i) (or char #\Replacement_Character))))))) 2863 2863 :memory-encode-function 2864 (nfunction 2865 utf-8-memory-encode 2866 (lambda (string pointer idx start end) 2867 (declare (fixnum idx)) 2868 (do* ((i start (1+ i))) 2869 ((>= i end) idx) 2870 (let* ((code (char-code (schar string i)))) 2871 (declare (type (mod #x110000) code)) 2872 (cond ((< code #x80) 2873 (setf (%get-unsigned-byte pointer idx) code) 2874 (incf idx)) 2875 ((< code #x800) 2876 (setf (%get-unsigned-byte pointer idx) 2877 (logior #xc0 (the fixnum (ash code -6)))) 2878 (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) 2879 (logior #x80 (the fixnum (logand code #x3f)))) 2880 (incf idx 2)) 2881 ((< code #x10000) 2882 (setf (%get-unsigned-byte pointer idx) 2883 (logior #xe0 (the fixnum (ash code -12)))) 2884 (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) 2885 (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) 2886 (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) 2887 (logior #x80 (the fixnum (logand code #x3f)))) 2888 (incf idx 3)) 2889 (t 2890 (setf (%get-unsigned-byte pointer idx) 2891 (logior #xf0 2892 (the fixnum (logand #x7 (the fixnum (ash code -18)))))) 2893 (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) 2894 (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) 2895 (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) 2896 (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) 2897 (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) 2898 (logand #x3f code)) 2899 (incf idx 4))))))) 2864 #'utf-8-memory-encode 2900 2865 :memory-decode-function 2901 (nfunction 2902 utf-8-memory-decode 2903 (lambda (pointer noctets idx string) 2904 (declare (fixnum noctets idx)) 2905 (do* ((i 0 (1+ i)) 2906 (end (+ idx noctets)) 2907 (index idx (1+ index))) 2908 ((>= index end) (if (= index end) index 0)) 2909 (let* ((1st-unit (%get-unsigned-byte pointer index))) 2910 (declare (type (unsigned-byte 8) 1st-unit)) 2911 (let* ((char (if (< 1st-unit #x80) 2912 (code-char 1st-unit) 2913 (if (>= 1st-unit #xc2) 2914 (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) 2915 (declare (type (unsigned-byte 8) 2nd-unit)) 2916 (if (< 1st-unit #xe0) 2917 (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) 2918 (code-char 2919 (logior 2920 (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) 2921 (the fixnum (logxor 2nd-unit #x80))))) 2922 (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) 2923 (declare (type (unsigned-byte 8) 3rd-unit)) 2924 (if (< 1st-unit #xf0) 2925 (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) 2926 (< (the fixnum (logxor 3rd-unit #x80)) #x40) 2927 (or (>= 1st-unit #xe1) 2928 (>= 2nd-unit #xa0))) 2929 (code-char (the fixnum 2930 (logior (the fixnum 2931 (ash (the fixnum (logand 1st-unit #xf)) 2932 12)) 2933 (the fixnum 2934 (logior 2935 (the fixnum 2936 (ash (the fixnum (logand 2nd-unit #x3f)) 2937 6)) 2938 (the fixnum (logand 3rd-unit #x3f)))))))) 2939 (if (< 1st-unit #xf8) 2940 (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) 2941 (declare (type (unsigned-byte 8) 4th-unit)) 2942 (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) 2943 (< (the fixnum (logxor 3rd-unit #x80)) #x40) 2944 (< (the fixnum (logxor 4th-unit #x80)) #x40) 2945 (or (>= 1st-unit #xf1) 2946 (>= 2nd-unit #x90))) 2947 (code-char 2948 (logior 2949 (the fixnum 2950 (logior 2951 (the fixnum 2952 (ash (the fixnum (logand 1st-unit 7)) 18)) 2953 (the fixnum 2954 (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) 2955 (the fixnum 2956 (logior 2957 (the fixnum 2958 (ash (the fixnum (logxor 3rd-unit #x80)) 6)) 2959 (the fixnum (logxor 4th-unit #x80))))))))))))))))) 2960 (setf (schar string i) (or char #\Replacement_Character))))))) 2866 #'utf-8-memory-decode 2961 2867 :octets-in-string-function 2962 (nfunction 2963 utf-8-octets-in-string 2964 (lambda (string start end) 2965 (if (>= end start) 2966 (do* ((noctets 0) 2967 (i start (1+ i))) 2968 ((= i end) noctets) 2969 (declare (fixnum noctets)) 2970 (let* ((code (char-code (schar string i)))) 2971 (declare (type (mod #x110000) code)) 2972 (incf noctets 2973 (if (< code #x80) 2974 1 2975 (if (< code #x800) 2976 2 2977 (if (< code #x10000) 2978 3 2979 4)))))) 2980 0))) 2868 #'utf-8-octets-in-string 2981 2869 :length-of-vector-encoding-function 2982 2870 (nfunction … … 2999 2887 (setq nchars (1+ nchars) i nexti)))))) 3000 2888 :length-of-memory-encoding-function 3001 (nfunction 3002 utf-8-length-of-memory-encoding 3003 (lambda (pointer noctets start) 3004 (do* ((i start) 3005 (end (+ start noctets)) 3006 (nchars 0 (1+ nchars))) 3007 ((= i end) (values nchars i)) 3008 (let* ((code (%get-unsigned-byte pointer i)) 3009 (nexti (+ i (cond ((< code #x80) 1) 3010 ((< code #xe0) 2) 3011 ((< code #xf0) 3) 3012 (t 4))))) 3013 (declare (type (unsigned-byte 8) code)) 3014 (if (> nexti end) 3015 (return (values nchars i)) 3016 (setq i nexti)))))) 2889 #'utf-8-length-of-memory-encoding 3017 2890 :decode-literal-code-unit-limit #x80 3018 2891 :encode-literal-char-code-limit #x80 … … 4651 4524 data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s)))))))) 4652 4525 4526 4527 4528 4529 4530 ;;; This is an array of 256 integers, that (sparsely) encodes 64K bits. 4531 ;;; (There might be as many as 256 significant bits in some of entries 4532 ;;; in this table.) 4533 (defstatic *bmp-combining-bitmap* 4534 #( 4535 #x00 4536 #x00 4537 #x00 4538 #xFFFF0000FFFFFFFFFFFFFFFFFFFF 4539 #x37800000000000000000000000000000000 4540 #x16BBFFFFFBFFFE000000000000000000000000000000000000 4541 #x3D9FFFC00000000000000000000000010000003FF8000000000000000000 4542 #x1FFC00000000000000000000007FFFFFF000000020000 4543 4544 #x00 4545 #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E 4546 #x3BBFD00000000000000E0003000000003987D000000000000004 4547 #x803DC7C0000000000000040000000000C0398FD00000000000000E 4548 #x603DDFC00000000000000C0000000000603DDFC00000000000000E 4549 #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C 4550 #x3F001BF20000000000000000000000007F8007F2000000000000 4551 #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000 4552 4553 #x3C0000003C7F00000000000 4554 #x7FFFFFF0000000000003FFFFE000000000000000000000000 4555 #x00 4556 #x00 4557 #x00 4558 #x00 4559 #x00 4560 #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000 4561 4562 #x2000000000000000000000000000000000000003800 4563 #x00 4564 #x00 4565 #x00 4566 #x00 4567 #x00 4568 #x00 4569 #x00 4570 4571 #x7FFFFFF0000000000000000000000000000000000000000000000000000 4572 #x00 4573 #x00 4574 #x00 4575 #x00 4576 #x00 4577 #x00 4578 #x00 4579 4580 #x00 4581 #x00 4582 #x00 4583 #x00 4584 #x00 4585 #x00 4586 #x00 4587 #x00 4588 4589 #x600000000000000000000000000FC0000000000 4590 #x00 4591 #x00 4592 #x00 4593 #x00 4594 #x00 4595 #x00 4596 #x00 4597 4598 #x00 4599 #x00 4600 #x00 4601 #x00 4602 #x00 4603 #x00 4604 #x00 4605 #x00 4606 4607 #x00 4608 #x00 4609 #x00 4610 #x00 4611 #x00 4612 #x00 4613 #x00 4614 #x00 4615 4616 #x00 4617 #x00 4618 #x00 4619 #x00 4620 #x00 4621 #x00 4622 #x00 4623 #x00 4624 4625 #x00 4626 #x00 4627 #x00 4628 #x00 4629 #x00 4630 #x00 4631 #x00 4632 #x00 4633 4634 #x00 4635 #x00 4636 #x00 4637 #x00 4638 #x00 4639 #x00 4640 #x00 4641 #x00 4642 4643 #x00 4644 #x00 4645 #x00 4646 #x00 4647 #x00 4648 #x00 4649 #x00 4650 #x00 4651 4652 #x00 4653 #x00 4654 #x00 4655 #x00 4656 #x00 4657 #x00 4658 #x00 4659 #x00 4660 4661 #x00 4662 #x00 4663 #x00 4664 #x00 4665 #x00 4666 #x00 4667 #x00 4668 #x00 4669 4670 #x00 4671 #x00 4672 #x00 4673 #x00 4674 #x00 4675 #x00 4676 #x00 4677 #x00 4678 4679 #x00 4680 #x00 4681 #x00 4682 #x00 4683 #x00 4684 #x00 4685 #x00 4686 #x00 4687 4688 #x00 4689 #x00 4690 #x00 4691 #x00 4692 #x00 4693 #x00 4694 #x00 4695 #x00 4696 4697 #x00 4698 #x00 4699 #x00 4700 #x00 4701 #x00 4702 #x00 4703 #x00 4704 #x00 4705 4706 #x00 4707 #x00 4708 #x00 4709 #x00 4710 #x00 4711 #x00 4712 #x00 4713 #x00 4714 4715 #x00 4716 #x00 4717 #x00 4718 #x00 4719 #x00 4720 #x00 4721 #x00 4722 #x00 4723 4724 #x00 4725 #x00 4726 #x00 4727 #x00 4728 #x00 4729 #x00 4730 #x00 4731 #x00 4732 4733 #x00 4734 #x00 4735 #x00 4736 #x00 4737 #x00 4738 #x00 4739 #x00 4740 #x00 4741 4742 #x00 4743 #x00 4744 #x00 4745 #x00 4746 #x00 4747 #x00 4748 #x00 4749 #x00 4750 4751 #x00 4752 #x00 4753 #x00 4754 #x00 4755 #x00 4756 #x00 4757 #x00 4758 #x00 4759 4760 #x00 4761 #x00 4762 #x00 4763 #x00 4764 #x00 4765 #x00 4766 #x00 4767 #x00 4768 4769 #x00 4770 #x00 4771 #x00 4772 #x00 4773 #x00 4774 #x00 4775 #x00 4776 #x00 4777 4778 #x00 4779 #x00 4780 #x00 4781 #x00 4782 #x00 4783 #x00 4784 #x00 4785 #x00 4786 4787 #x00 4788 #x00 4789 #x00 4790 #x00 4791 #x00 4792 #x00 4793 #x00 4794 #x00 4795 4796 #x00 4797 #x00 4798 #x00 4799 #x00 4800 #x00 4801 #x00 4802 #x00 4803 #x00 4804 4805 #x00 4806 #x00 4807 #x00 4808 #x00 4809 #x00 4810 #x00 4811 #x00 4812 #x00 4813 4814 #x00 4815 #x00 4816 #x00 4817 #x40000000 4818 #x00 4819 #x00 4820 #xF0000FFFF 4821 #x00)) 4822 4823 (defun is-combinable (char) 4824 (let* ((code (char-code char))) 4825 (declare (type (mod #x110000) code)) 4826 (when (< code #x1000) 4827 (logbitp (ldb (byte 8 0) code) 4828 (svref *bmp-combining-bitmap* (ldb (byte 8 8) code)))))) 4829 4830 (defstatic *bmp-combining-chars* 4831 #(#\Combining_Grave_Accent 4832 #\Combining_Acute_Accent 4833 #\Combining_Circumflex_Accent 4834 #\Combining_Tilde 4835 #\Combining_Macron 4836 #\Combining_Breve 4837 #\Combining_Dot_Above 4838 #\Combining_Diaeresis 4839 #\Combining_Hook_Above 4840 #\Combining_Ring_Above 4841 #\Combining_Double_Acute_Accent 4842 #\Combining_Caron 4843 #\Combining_Double_Grave_Accent 4844 #\Combining_Inverted_Breve 4845 #\Combining_Comma_Above 4846 #\Combining_Reversed_Comma_Above 4847 #\Combining_Horn 4848 #\Combining_Dot_Below 4849 #\Combining_Diaeresis_Below 4850 #\Combining_Ring_Below 4851 #\Combining_Comma_Below 4852 #\Combining_Cedilla 4853 #\Combining_Ogonek 4854 #\Combining_Circumflex_Accent_Below 4855 #\Combining_Breve_Below 4856 #\Combining_Tilde_Below 4857 #\Combining_Macron_Below 4858 #\Combining_Long_Solidus_Overlay 4859 #\Combining_Greek_Perispomeni 4860 #\Combining_Greek_Ypogegrammeni 4861 #\Arabic_Maddah_Above 4862 #\Arabic_Hamza_Above 4863 #\Arabic_Hamza_Below 4864 #\U+093C 4865 #\U+09BE 4866 #\U+09D7 4867 #\U+0B3E 4868 #\U+0B56 4869 #\U+0B57 4870 #\U+0BBE 4871 #\U+0BD7 4872 #\U+0C56 4873 #\U+0CC2 4874 #\U+0CD5 4875 #\U+0CD6 4876 #\U+0D3E 4877 #\U+0D57 4878 #\U+0DCA 4879 #\U+0DCF 4880 #\U+0DDF 4881 #\U+102E 4882 #\U+3099 4883 #\U+309A)) 4884 4885 (defstatic *bmp-combining-base-chars* 4886 #( 4887 ;; #\Combining_Grave_Accent 4888 4889 #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y 4890 #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex 4891 #\Latin_Capital_Letter_E_With_Circumflex 4892 #\Latin_Capital_Letter_O_With_Circumflex 4893 #\Latin_Capital_Letter_U_With_Diaeresis 4894 #\Latin_Small_Letter_A_With_Circumflex 4895 #\Latin_Small_Letter_E_With_Circumflex 4896 #\Latin_Small_Letter_O_With_Circumflex 4897 #\Latin_Small_Letter_U_With_Diaeresis 4898 #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve 4899 #\Latin_Capital_Letter_E_With_Macron 4900 #\Latin_Small_Letter_E_With_Macron 4901 #\Latin_Capital_Letter_O_With_Macron 4902 #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn 4903 #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn 4904 #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha 4905 #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta 4906 #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron 4907 #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega 4908 #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon 4909 #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota 4910 #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon 4911 #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika 4912 #\Greek_Small_Letter_Upsilon_With_Dialytika 4913 #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I 4914 #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01 4915 #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 4916 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 4917 #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 4918 #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) 4919 4920 4921 ;; #\Combining_Acute_Accent 4922 4923 #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z 4924 #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z 4925 #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex 4926 #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae 4927 #\Latin_Capital_Letter_C_With_Cedilla 4928 #\Latin_Capital_Letter_E_With_Circumflex 4929 #\Latin_Capital_Letter_I_With_Diaeresis 4930 #\Latin_Capital_Letter_O_With_Circumflex 4931 #\Latin_Capital_Letter_O_With_Tilde 4932 #\Latin_Capital_Letter_O_With_Stroke 4933 #\Latin_Capital_Letter_U_With_Diaeresis 4934 #\Latin_Small_Letter_A_With_Circumflex 4935 #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae 4936 #\Latin_Small_Letter_C_With_Cedilla 4937 #\Latin_Small_Letter_E_With_Circumflex 4938 #\Latin_Small_Letter_I_With_Diaeresis 4939 #\Latin_Small_Letter_O_With_Circumflex 4940 #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke 4941 #\Latin_Small_Letter_U_With_Diaeresis 4942 #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve 4943 #\Latin_Capital_Letter_E_With_Macron 4944 #\Latin_Small_Letter_E_With_Macron 4945 #\Latin_Capital_Letter_O_With_Macron 4946 #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde 4947 #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn 4948 #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn 4949 #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha 4950 #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta 4951 #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron 4952 #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega 4953 #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon 4954 #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota 4955 #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon 4956 #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika 4957 #\Greek_Small_Letter_Upsilon_With_Dialytika 4958 #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe 4959 #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe 4960 #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09 4961 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28 4962 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41 4963 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 4964 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) 4965 4966 4967 ;; #\Combining_Circumflex_Accent 4968 4969 #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g 4970 #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8 4971 #\U+1EB9 #\U+1ECC #\U+1ECD) 4972 4973 4974 ;; #\Combining_Tilde 4975 4976 #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y 4977 #\Latin_Capital_Letter_A_With_Circumflex 4978 #\Latin_Capital_Letter_E_With_Circumflex 4979 #\Latin_Capital_Letter_O_With_Circumflex 4980 #\Latin_Small_Letter_A_With_Circumflex 4981 #\Latin_Small_Letter_E_With_Circumflex 4982 #\Latin_Small_Letter_O_With_Circumflex 4983 #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve 4984 #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn 4985 #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) 4986 4987 4988 ;; #\Combining_Macron 4989 4990 #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y 4991 #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae 4992 #\Latin_Capital_Letter_O_With_Tilde 4993 #\Latin_Capital_Letter_O_With_Diaeresis 4994 #\Latin_Capital_Letter_U_With_Diaeresis 4995 #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae 4996 #\Latin_Small_Letter_O_With_Tilde 4997 #\Latin_Small_Letter_O_With_Diaeresis 4998 #\Latin_Small_Letter_U_With_Diaeresis 4999 #\Latin_Capital_Letter_O_With_Ogonek 5000 #\Latin_Small_Letter_O_With_Ogonek 5001 #\Latin_Capital_Letter_A_With_Dot_Above 5002 #\Latin_Small_Letter_A_With_Dot_Above 5003 #\Latin_Capital_Letter_O_With_Dot_Above 5004 #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha 5005 #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon 5006 #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota 5007 #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I 5008 #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I 5009 #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B) 5010 5011 5012 ;; #\Combining_Breve 5013 5014 #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u 5015 #\Latin_Capital_Letter_E_With_Cedilla 5016 #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha 5017 #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon 5018 #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota 5019 #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A 5020 #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe 5021 #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U 5022 #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie 5023 #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I 5024 #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1) 5025 5026 5027 ;; #\Combining_Dot_Above 5028 5029 #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W 5030 #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s 5031 #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute 5032 #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron 5033 #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62 5034 #\U+1E63) 5035 5036 5037 ;; #\Combining_Diaeresis 5038 5039 #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w 5040 #\x #\y #\Latin_Capital_Letter_O_With_Tilde 5041 #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron 5042 #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota 5043 #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota 5044 #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol 5045 #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I 5046 #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie 5047 #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze 5048 #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O 5049 #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che 5050 #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E 5051 #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie 5052 #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze 5053 #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O 5054 #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che 5055 #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E 5056 #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I 5057 #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa 5058 #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O) 5059 5060 5061 ;; #\Combining_Hook_Above 5062 5063 #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y 5064 #\Latin_Capital_Letter_A_With_Circumflex 5065 #\Latin_Capital_Letter_E_With_Circumflex 5066 #\Latin_Capital_Letter_O_With_Circumflex 5067 #\Latin_Small_Letter_A_With_Circumflex 5068 #\Latin_Small_Letter_E_With_Circumflex 5069 #\Latin_Small_Letter_O_With_Circumflex 5070 #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve 5071 #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn 5072 #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) 5073 5074 5075 ;; #\Combining_Ring_Above 5076 5077 #(#\A #\U #\a #\u #\w #\y) 5078 5079 5080 ;; #\Combining_Double_Acute_Accent 5081 5082 #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U 5083 #\Cyrillic_Small_Letter_U) 5084 5085 5086 ;; #\Combining_Caron 5087 5088 #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a 5089 #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z 5090 #\Latin_Capital_Letter_U_With_Diaeresis 5091 #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh 5092 #\Latin_Small_Letter_Ezh) 5093 5094 5095 ;; #\Combining_Double_Grave_Accent 5096 5097 #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u 5098 #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa) 5099 5100 5101 ;; #\Combining_Inverted_Breve 5102 5103 #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u) 5104 5105 5106 ;; #\Combining_Comma_Above 5107 5108 #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon 5109 #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota 5110 #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega 5111 #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon 5112 #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota 5113 #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho 5114 #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) 5115 5116 5117 ;; #\Combining_Reversed_Comma_Above 5118 5119 #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon 5120 #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota 5121 #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho 5122 #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega 5123 #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon 5124 #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota 5125 #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho 5126 #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) 5127 5128 5129 ;; #\Combining_Horn 5130 5131 #(#\O #\U #\o #\u) 5132 5133 5134 ;; #\Combining_Dot_Below 5135 5136 #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W 5137 #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u 5138 #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn 5139 #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn 5140 #\Latin_Small_Letter_U_With_Horn) 5141 5142 5143 ;; #\Combining_Diaeresis_Below 5144 5145 #(#\U #\u) 5146 5147 5148 ;; #\Combining_Ring_Below 5149 5150 #(#\A #\a) 5151 5152 5153 ;; #\Combining_Comma_Below 5154 5155 #(#\S #\T #\s #\t) 5156 5157 5158 ;; #\Combining_Cedilla 5159 5160 #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k 5161 #\l #\n #\r #\s #\t) 5162 5163 5164 ;; #\Combining_Ogonek 5165 5166 #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u) 5167 5168 5169 ;; #\Combining_Circumflex_Accent_Below 5170 5171 #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u) 5172 5173 5174 ;; #\Combining_Breve_Below 5175 5176 #(#\H #\h) 5177 5178 5179 ;; #\Combining_Tilde_Below 5180 5181 #(#\E #\I #\U #\e #\i #\u) 5182 5183 5184 ;; #\Combining_Macron_Below 5185 5186 #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z) 5187 5188 5189 ;; #\Combining_Long_Solidus_Overlay 5190 5191 #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4 5192 #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243 5193 #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272 5194 #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D 5195 #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2 5196 #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5) 5197 5198 5199 ;; #\Combining_Greek_Perispomeni 5200 5201 #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta 5202 #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon 5203 #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika 5204 #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08 5205 #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 5206 #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 5207 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) 5208 5209 5210 ;; #\Combining_Greek_Ypogegrammeni 5211 5212 #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta 5213 #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos 5214 #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha 5215 #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega 5216 #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02 5217 #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09 5218 #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20 5219 #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27 5220 #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E 5221 #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65 5222 #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C 5223 #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6 5224 #\U+1FC6 #\U+1FF6) 5225 5226 5227 ;; #\Arabic_Maddah_Above 5228 5229 #(#\Arabic_Letter_Alef) 5230 5231 5232 ;; #\Arabic_Hamza_Above 5233 5234 #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh 5235 #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree 5236 #\Arabic_Letter_Ae) 5237 5238 5239 ;; #\Arabic_Hamza_Below 5240 5241 #(#\Arabic_Letter_Alef) 5242 5243 5244 ;; #\U+093C 5245 5246 #(#\U+0928 #\U+0930 #\U+0933) 5247 5248 5249 ;; #\U+09BE 5250 5251 #(#\U+09C7) 5252 5253 5254 ;; #\U+09D7 5255 5256 #(#\U+09C7) 5257 5258 5259 ;; #\U+0B3E 5260 5261 #(#\U+0B47) 5262 5263 5264 ;; #\U+0B56 5265 5266 #(#\U+0B47) 5267 5268 5269 ;; #\U+0B57 5270 5271 #(#\U+0B47) 5272 5273 5274 ;; #\U+0BBE 5275 5276 #(#\U+0BC6 #\U+0BC7) 5277 5278 5279 ;; #\U+0BD7 5280 5281 #(#\U+0B92 #\U+0BC6) 5282 5283 5284 ;; #\U+0C56 5285 5286 #(#\U+0C46) 5287 5288 5289 ;; #\U+0CC2 5290 5291 #(#\U+0CC6) 5292 5293 5294 ;; #\U+0CD5 5295 5296 #(#\U+0CBF #\U+0CC6 #\U+0CCA) 5297 5298 5299 ;; #\U+0CD6 5300 5301 #(#\U+0CC6) 5302 5303 5304 ;; #\U+0D3E 5305 5306 #(#\U+0D46 #\U+0D47) 5307 5308 5309 ;; #\U+0D57 5310 5311 #(#\U+0D46) 5312 5313 5314 ;; #\U+0DCA 5315 5316 #(#\U+0DD9 #\U+0DDC) 5317 5318 5319 ;; #\U+0DCF 5320 5321 #(#\U+0DD9) 5322 5323 5324 ;; #\U+0DDF 5325 5326 #(#\U+0DD9) 5327 5328 5329 ;; #\U+102E 5330 5331 #(#\U+1025) 5332 5333 5334 ;; #\U+3099 5335 5336 #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055 5337 #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064 5338 #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B 5339 #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3 5340 #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1 5341 #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8 5342 #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD) 5343 5344 5345 ;; #\U+309A 5346 5347 #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2 5348 #\U+30D5 #\U+30D8 #\U+30DB) 5349 )) 5350 5351 (defstatic *bmp-precombined-chars* 5352 #( 5353 5354 ;; #\Combining_Grave_Accent 5355 5356 #(#\Latin_Capital_Letter_A_With_Grave 5357 #\Latin_Capital_Letter_E_With_Grave 5358 #\Latin_Capital_Letter_I_With_Grave 5359 #\Latin_Capital_Letter_N_With_Grave 5360 #\Latin_Capital_Letter_O_With_Grave 5361 #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2 5362 #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave 5363 #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave 5364 #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave 5365 #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2 5366 #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1 5367 #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0 5368 #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD 5369 #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8 5370 #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78 5371 #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2 5372 #\Cyrillic_Capital_Letter_Ie_With_Grave 5373 #\Cyrillic_Capital_Letter_I_With_Grave 5374 #\Cyrillic_Small_Letter_Ie_With_Grave 5375 #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A 5376 #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23 5377 #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42 5378 #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62 5379 #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD) 5380 5381 5382 ;; #\Combining_Acute_Accent 5383 5384 #(#\Latin_Capital_Letter_A_With_Acute 5385 #\Latin_Capital_Letter_C_With_Acute 5386 #\Latin_Capital_Letter_E_With_Acute 5387 #\Latin_Capital_Letter_G_With_Acute 5388 #\Latin_Capital_Letter_I_With_Acute #\U+1E30 5389 #\Latin_Capital_Letter_L_With_Acute #\U+1E3E 5390 #\Latin_Capital_Letter_N_With_Acute 5391 #\Latin_Capital_Letter_O_With_Acute #\U+1E54 5392 #\Latin_Capital_Letter_R_With_Acute 5393 #\Latin_Capital_Letter_S_With_Acute 5394 #\Latin_Capital_Letter_U_With_Acute #\U+1E82 5395 #\Latin_Capital_Letter_Y_With_Acute 5396 #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute 5397 #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute 5398 #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute 5399 #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F 5400 #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute 5401 #\U+1E55 #\Latin_Small_Letter_R_With_Acute 5402 #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute 5403 #\U+1E83 #\Latin_Small_Letter_Y_With_Acute 5404 #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4 5405 #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute 5406 #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E 5407 #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute 5408 #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5 5409 #\Latin_Small_Letter_A_With_Ring_Above_And_Acute 5410 #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1 5411 #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute 5412 #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF 5413 #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA 5414 #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos 5415 #\Greek_Capital_Letter_Epsilon_With_Tonos 5416 #\Greek_Capital_Letter_Eta_With_Tonos 5417 #\Greek_Capital_Letter_Iota_With_Tonos 5418 #\Greek_Capital_Letter_Omicron_With_Tonos 5419 #\Greek_Capital_Letter_Upsilon_With_Tonos 5420 #\Greek_Capital_Letter_Omega_With_Tonos 5421 #\Greek_Small_Letter_Alpha_With_Tonos 5422 #\Greek_Small_Letter_Epsilon_With_Tonos 5423 #\Greek_Small_Letter_Eta_With_Tonos 5424 #\Greek_Small_Letter_Iota_With_Tonos 5425 #\Greek_Small_Letter_Omicron_With_Tonos 5426 #\Greek_Small_Letter_Upsilon_With_Tonos 5427 #\Greek_Small_Letter_Omega_With_Tonos 5428 #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos 5429 #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos 5430 #\Greek_Upsilon_With_Acute_And_Hook_Symbol 5431 #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje 5432 #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04 5433 #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D 5434 #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C 5435 #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55 5436 #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE) 5437 5438 5439 ;; #\Combining_Circumflex_Accent 5440 5441 #(#\Latin_Capital_Letter_A_With_Circumflex 5442 #\Latin_Capital_Letter_C_With_Circumflex 5443 #\Latin_Capital_Letter_E_With_Circumflex 5444 #\Latin_Capital_Letter_G_With_Circumflex 5445 #\Latin_Capital_Letter_H_With_Circumflex 5446 #\Latin_Capital_Letter_I_With_Circumflex 5447 #\Latin_Capital_Letter_J_With_Circumflex 5448 #\Latin_Capital_Letter_O_With_Circumflex 5449 #\Latin_Capital_Letter_S_With_Circumflex 5450 #\Latin_Capital_Letter_U_With_Circumflex 5451 #\Latin_Capital_Letter_W_With_Circumflex 5452 #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90 5453 #\Latin_Small_Letter_A_With_Circumflex 5454 #\Latin_Small_Letter_C_With_Circumflex 5455 #\Latin_Small_Letter_E_With_Circumflex 5456 #\Latin_Small_Letter_G_With_Circumflex 5457 #\Latin_Small_Letter_H_With_Circumflex 5458 #\Latin_Small_Letter_I_With_Circumflex 5459 #\Latin_Small_Letter_J_With_Circumflex 5460 #\Latin_Small_Letter_O_With_Circumflex 5461 #\Latin_Small_Letter_S_With_Circumflex 5462 #\Latin_Small_Letter_U_With_Circumflex 5463 #\Latin_Small_Letter_W_With_Circumflex 5464 #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD 5465 #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9) 5466 5467 5468 ;; #\Combining_Tilde 5469 5470 #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC 5471 #\Latin_Capital_Letter_I_With_Tilde 5472 #\Latin_Capital_Letter_N_With_Tilde 5473 #\Latin_Capital_Letter_O_With_Tilde 5474 #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8 5475 #\Latin_Small_Letter_A_With_Tilde #\U+1EBD 5476 #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde 5477 #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde 5478 #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5 5479 #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF) 5480 5481 5482 ;; #\Combining_Macron 5483 5484 #(#\Latin_Capital_Letter_A_With_Macron 5485 #\Latin_Capital_Letter_E_With_Macron #\U+1E20 5486 #\Latin_Capital_Letter_I_With_Macron 5487 #\Latin_Capital_Letter_O_With_Macron 5488 #\Latin_Capital_Letter_U_With_Macron 5489 #\Latin_Capital_Letter_Y_With_Macron 5490 #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron 5491 #\U+1E21 #\Latin_Small_Letter_I_With_Macron 5492 #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron 5493 #\Latin_Small_Letter_Y_With_Macron 5494 #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron 5495 #\Latin_Capital_Letter_Ae_With_Macron 5496 #\Latin_Capital_Letter_O_With_Tilde_And_Macron 5497 #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron 5498 #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron 5499 #\Latin_Small_Letter_A_With_Diaeresis_And_Macron 5500 #\Latin_Small_Letter_Ae_With_Macron 5501 #\Latin_Small_Letter_O_With_Tilde_And_Macron 5502 #\Latin_Small_Letter_O_With_Diaeresis_And_Macron 5503 #\Latin_Small_Letter_U_With_Diaeresis_And_Macron 5504 #\Latin_Capital_Letter_O_With_Ogonek_And_Macron 5505 #\Latin_Small_Letter_O_With_Ogonek_And_Macron 5506 #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron 5507 #\Latin_Small_Letter_A_With_Dot_Above_And_Macron 5508 #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron 5509 #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9 5510 #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1 5511 #\Cyrillic_Capital_Letter_I_With_Macron 5512 #\Cyrillic_Capital_Letter_U_With_Macron 5513 #\Cyrillic_Small_Letter_I_With_Macron 5514 #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C 5515 #\U+1E5D) 5516 5517 5518 ;; #\Combining_Breve 5519 5520 #(#\Latin_Capital_Letter_A_With_Breve 5521 #\Latin_Capital_Letter_E_With_Breve 5522 #\Latin_Capital_Letter_G_With_Breve 5523 #\Latin_Capital_Letter_I_With_Breve 5524 #\Latin_Capital_Letter_O_With_Breve 5525 #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve 5526 #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve 5527 #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve 5528 #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8 5529 #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0 5530 #\Cyrillic_Capital_Letter_A_With_Breve 5531 #\Cyrillic_Capital_Letter_Ie_With_Breve 5532 #\Cyrillic_Capital_Letter_Zhe_With_Breve 5533 #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U 5534 #\Cyrillic_Small_Letter_A_With_Breve 5535 #\Cyrillic_Small_Letter_Ie_With_Breve 5536 #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I 5537 #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7) 5538 5539 5540 ;; #\Combining_Dot_Above 5541 5542 #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02 5543 #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A 5544 #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E 5545 #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22 5546 #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44 5547 #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60 5548 #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E 5549 #\Latin_Capital_Letter_Z_With_Dot_Above 5550 #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03 5551 #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B 5552 #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F 5553 #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45 5554 #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61 5555 #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F 5556 #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66 5557 #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69) 5558 5559 5560 ;; #\Combining_Diaeresis 5561 5562 #(#\Latin_Capital_Letter_A_With_Diaeresis 5563 #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26 5564 #\Latin_Capital_Letter_I_With_Diaeresis 5565 #\Latin_Capital_Letter_O_With_Diaeresis 5566 #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C 5567 #\Latin_Capital_Letter_Y_With_Diaeresis 5568 #\Latin_Small_Letter_A_With_Diaeresis 5569 #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27 5570 #\Latin_Small_Letter_I_With_Diaeresis 5571 #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97 5572 #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D 5573 #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A 5574 #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika 5575 #\Greek_Capital_Letter_Upsilon_With_Dialytika 5576 #\Greek_Small_Letter_Iota_With_Dialytika 5577 #\Greek_Small_Letter_Upsilon_With_Dialytika 5578 #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol 5579 #\Cyrillic_Capital_Letter_Yi 5580 #\Cyrillic_Capital_Letter_A_With_Diaeresis 5581 #\Cyrillic_Capital_Letter_Io 5582 #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis 5583 #\Cyrillic_Capital_Letter_Ze_With_Diaeresis 5584 #\Cyrillic_Capital_Letter_I_With_Diaeresis 5585 #\Cyrillic_Capital_Letter_O_With_Diaeresis 5586 #\Cyrillic_Capital_Letter_U_With_Diaeresis 5587 #\Cyrillic_Capital_Letter_Che_With_Diaeresis 5588 #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis 5589 #\Cyrillic_Capital_Letter_E_With_Diaeresis 5590 #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io 5591 #\Cyrillic_Small_Letter_Zhe_With_Diaeresis 5592 #\Cyrillic_Small_Letter_Ze_With_Diaeresis 5593 #\Cyrillic_Small_Letter_I_With_Diaeresis 5594 #\Cyrillic_Small_Letter_O_With_Diaeresis 5595 #\Cyrillic_Small_Letter_U_With_Diaeresis 5596 #\Cyrillic_Small_Letter_Che_With_Diaeresis 5597 #\Cyrillic_Small_Letter_Yeru_With_Diaeresis 5598 #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi 5599 #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis 5600 #\Cyrillic_Small_Letter_Schwa_With_Diaeresis 5601 #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis 5602 #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis) 5603 5604 5605 ;; #\Combining_Hook_Above 5606 5607 #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3 5608 #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2 5609 #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE 5610 #\U+1EDF #\U+1EEC #\U+1EED) 5611 5612 5613 ;; #\Combining_Ring_Above 5614 5615 #(#\Latin_Capital_Letter_A_With_Ring_Above 5616 #\Latin_Capital_Letter_U_With_Ring_Above 5617 #\Latin_Small_Letter_A_With_Ring_Above 5618 #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99) 5619 5620 5621 ;; #\Combining_Double_Acute_Accent 5622 5623 #(#\Latin_Capital_Letter_O_With_Double_Acute 5624 #\Latin_Capital_Letter_U_With_Double_Acute 5625 #\Latin_Small_Letter_O_With_Double_Acute 5626 #\Latin_Small_Letter_U_With_Double_Acute 5627 #\Cyrillic_Capital_Letter_U_With_Double_Acute 5628 #\Cyrillic_Small_Letter_U_With_Double_Acute) 5629 5630 5631 ;; #\Combining_Caron 5632 5633 #(#\Latin_Capital_Letter_A_With_Caron 5634 #\Latin_Capital_Letter_C_With_Caron 5635 #\Latin_Capital_Letter_D_With_Caron 5636 #\Latin_Capital_Letter_E_With_Caron 5637 #\Latin_Capital_Letter_G_With_Caron 5638 #\Latin_Capital_Letter_H_With_Caron 5639 #\Latin_Capital_Letter_I_With_Caron 5640 #\Latin_Capital_Letter_K_With_Caron 5641 #\Latin_Capital_Letter_L_With_Caron 5642 #\Latin_Capital_Letter_N_With_Caron 5643 #\Latin_Capital_Letter_O_With_Caron 5644 #\Latin_Capital_Letter_R_With_Caron 5645 #\Latin_Capital_Letter_S_With_Caron 5646 #\Latin_Capital_Letter_T_With_Caron 5647 #\Latin_Capital_Letter_U_With_Caron 5648 #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron 5649 #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron 5650 #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron 5651 #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron 5652 #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron 5653 #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron 5654 #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron 5655 #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron 5656 #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron 5657 #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron 5658 #\Latin_Small_Letter_U_With_Diaeresis_And_Caron 5659 #\Latin_Capital_Letter_Ezh_With_Caron 5660 #\Latin_Small_Letter_Ezh_With_Caron) 5661 5662 5663 ;; #\Combining_Double_Grave_Accent 5664 5665 #(#\Latin_Capital_Letter_A_With_Double_Grave 5666 #\Latin_Capital_Letter_E_With_Double_Grave 5667 #\Latin_Capital_Letter_I_With_Double_Grave 5668 #\Latin_Capital_Letter_O_With_Double_Grave 5669 #\Latin_Capital_Letter_R_With_Double_Grave 5670 #\Latin_Capital_Letter_U_With_Double_Grave 5671 #\Latin_Small_Letter_A_With_Double_Grave 5672 #\Latin_Small_Letter_E_With_Double_Grave 5673 #\Latin_Small_Letter_I_With_Double_Grave 5674 #\Latin_Small_Letter_O_With_Double_Grave 5675 #\Latin_Small_Letter_R_With_Double_Grave 5676 #\Latin_Small_Letter_U_With_Double_Grave 5677 #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent 5678 #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent) 5679 5680 5681 ;; #\Combining_Inverted_Breve 5682 5683 #(#\Latin_Capital_Letter_A_With_Inverted_Breve 5684 #\Latin_Capital_Letter_E_With_Inverted_Breve 5685 #\Latin_Capital_Letter_I_With_Inverted_Breve 5686 #\Latin_Capital_Letter_O_With_Inverted_Breve 5687 #\Latin_Capital_Letter_R_With_Inverted_Breve 5688 #\Latin_Capital_Letter_U_With_Inverted_Breve 5689 #\Latin_Small_Letter_A_With_Inverted_Breve 5690 #\Latin_Small_Letter_E_With_Inverted_Breve 5691 #\Latin_Small_Letter_I_With_Inverted_Breve 5692 #\Latin_Small_Letter_O_With_Inverted_Breve 5693 #\Latin_Small_Letter_R_With_Inverted_Breve 5694 #\Latin_Small_Letter_U_With_Inverted_Breve) 5695 5696 5697 ;; #\Combining_Comma_Above 5698 5699 #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00 5700 #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60) 5701 5702 5703 ;; #\Combining_Reversed_Comma_Above 5704 5705 #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59 5706 #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5 5707 #\U+1F51 #\U+1F61) 5708 5709 5710 ;; #\Combining_Horn 5711 5712 #(#\Latin_Capital_Letter_O_With_Horn 5713 #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn 5714 #\Latin_Small_Letter_U_With_Horn) 5715 5716 5717 ;; #\Combining_Dot_Below 5718 5719 #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32 5720 #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C 5721 #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05 5722 #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43 5723 #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F 5724 #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1) 5725 5726 5727 ;; #\Combining_Diaeresis_Below 5728 5729 #(#\U+1E72 #\U+1E73) 5730 5731 5732 ;; #\Combining_Ring_Below 5733 5734 #(#\U+1E00 #\U+1E01) 5735 5736 5737 ;; #\Combining_Comma_Below 5738 5739 #(#\Latin_Capital_Letter_S_With_Comma_Below 5740 #\Latin_Capital_Letter_T_With_Comma_Below 5741 #\Latin_Small_Letter_S_With_Comma_Below 5742 #\Latin_Small_Letter_T_With_Comma_Below) 5743 5744 5745 ;; #\Combining_Cedilla 5746 5747 #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10 5748 #\Latin_Capital_Letter_E_With_Cedilla 5749 #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28 5750 #\Latin_Capital_Letter_K_With_Cedilla 5751 #\Latin_Capital_Letter_L_With_Cedilla 5752 #\Latin_Capital_Letter_N_With_Cedilla 5753 #\Latin_Capital_Letter_R_With_Cedilla 5754 #\Latin_Capital_Letter_S_With_Cedilla 5755 #\Latin_Capital_Letter_T_With_Cedilla 5756 #\Latin_Small_Letter_C_With_Cedilla #\U+1E11 5757 #\Latin_Small_Letter_E_With_Cedilla 5758 #\Latin_Small_Letter_G_With_Cedilla #\U+1E29 5759 #\Latin_Small_Letter_K_With_Cedilla 5760 #\Latin_Small_Letter_L_With_Cedilla 5761 #\Latin_Small_Letter_N_With_Cedilla 5762 #\Latin_Small_Letter_R_With_Cedilla 5763 #\Latin_Small_Letter_S_With_Cedilla 5764 #\Latin_Small_Letter_T_With_Cedilla) 5765 5766 5767 ;; #\Combining_Ogonek 5768 5769 #(#\Latin_Capital_Letter_A_With_Ogonek 5770 #\Latin_Capital_Letter_E_With_Ogonek 5771 #\Latin_Capital_Letter_I_With_Ogonek 5772 #\Latin_Capital_Letter_O_With_Ogonek 5773 #\Latin_Capital_Letter_U_With_Ogonek 5774 #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek 5775 #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek 5776 #\Latin_Small_Letter_U_With_Ogonek) 5777 5778 5779 ;; #\Combining_Circumflex_Accent_Below 5780 5781 #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13 5782 #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77) 5783 5784 5785 ;; #\Combining_Breve_Below 5786 5787 #(#\U+1E2A #\U+1E2B) 5788 5789 5790 ;; #\Combining_Tilde_Below 5791 5792 #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75) 5793 5794 5795 ;; #\Combining_Macron_Below 5796 5797 #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E 5798 #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49 5799 #\U+1E5F #\U+1E6F #\U+1E95) 5800 5801 5802 ;; #\Combining_Long_Solidus_Overlay 5803 5804 #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD 5805 #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226 5806 #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270 5807 #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281 5808 #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2 5809 #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB 5810 #\U+22EC #\U+22ED) 5811 5812 5813 ;; #\Combining_Greek_Perispomeni 5814 5815 #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7 5816 #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27 5817 #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56 5818 #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF 5819 #\U+1FDF) 5820 5821 5822 ;; #\Combining_Greek_Ypogegrammeni 5823 5824 #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3 5825 #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84 5826 #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B 5827 #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92 5828 #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99 5829 #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0 5830 #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7 5831 #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE 5832 #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7) 5833 5834 5835 ;; #\Arabic_Maddah_Above 5836 5837 #(#\Arabic_Letter_Alef_With_Madda_Above) 5838 5839 5840 ;; #\Arabic_Hamza_Above 5841 5842 #(#\Arabic_Letter_Alef_With_Hamza_Above 5843 #\Arabic_Letter_Waw_With_Hamza_Above 5844 #\Arabic_Letter_Yeh_With_Hamza_Above 5845 #\Arabic_Letter_Heh_Goal_With_Hamza_Above 5846 #\Arabic_Letter_Yeh_Barree_With_Hamza_Above 5847 #\Arabic_Letter_Heh_With_Yeh_Above) 5848 5849 5850 ;; #\Arabic_Hamza_Below 5851 5852 #(#\Arabic_Letter_Alef_With_Hamza_Below) 5853 5854 5855 ;; #\U+093C 5856 5857 #(#\U+0929 #\U+0931 #\U+0934) 5858 5859 5860 ;; #\U+09BE 5861 5862 #(#\U+09CB) 5863 5864 5865 ;; #\U+09D7 5866 5867 #(#\U+09CC) 5868 5869 5870 ;; #\U+0B3E 5871 5872 #(#\U+0B4B) 5873 5874 5875 ;; #\U+0B56 5876 5877 #(#\U+0B48) 5878 5879 5880 ;; #\U+0B57 5881 5882 #(#\U+0B4C) 5883 5884 5885 ;; #\U+0BBE 5886 5887 #(#\U+0BCA #\U+0BCB) 5888 5889 5890 ;; #\U+0BD7 5891 5892 #(#\U+0B94 #\U+0BCC) 5893 5894 5895 ;; #\U+0C56 5896 5897 #(#\U+0C48) 5898 5899 5900 ;; #\U+0CC2 5901 5902 #(#\U+0CCA) 5903 5904 5905 ;; #\U+0CD5 5906 5907 #(#\U+0CC0 #\U+0CC7 #\U+0CCB) 5908 5909 5910 ;; #\U+0CD6 5911 5912 #(#\U+0CC8) 5913 5914 5915 ;; #\U+0D3E 5916 5917 #(#\U+0D4A #\U+0D4B) 5918 5919 5920 ;; #\U+0D57 5921 5922 #(#\U+0D4C) 5923 5924 5925 ;; #\U+0DCA 5926 5927 #(#\U+0DDA #\U+0DDD) 5928 5929 5930 ;; #\U+0DCF 5931 5932 #(#\U+0DDC) 5933 5934 5935 ;; #\U+0DDF 5936 5937 #(#\U+0DDE) 5938 5939 5940 ;; #\U+102E 5941 5942 #(#\U+1026) 5943 5944 5945 ;; #\U+3099 5946 5947 #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056 5948 #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065 5949 #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C 5950 #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4 5951 #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2 5952 #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9 5953 #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE) 5954 5955 5956 ;; #\U+309A 5957 5958 #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4 5959 #\U+30D7 #\U+30DA #\U+30DD) 5960 )) 5961 5962 (defun search-char-vector (vector char) 5963 ;; vector is a SIMPLE-VECTOR of chars sorted by char-code. 5964 ;; return the index of char in vector or NIL if not found 5965 (let* ((left 0) 5966 (right (1- (length vector)))) 5967 (declare (fixnum left right)) 5968 (if (and (char>= char (svref vector left)) 5969 (char<= char (svref vector right))) 5970 (do* () 5971 ((> left right)) 5972 (let* ((mid (ash (the fixnum (+ left right)) -1)) 5973 (midch (svref vector mid))) 5974 (declare (fixnum mid)) 5975 (if (eql char midch) 5976 (return mid) 5977 (if (char< char midch) 5978 (setq right (1- mid)) 5979 (setq left (1+ mid))))))))) 5980 5981 5982 (defconstant HANGUL-SBASE #xAC00) 5983 (defconstant HANGUL-LBASE #x1100) 5984 (defconstant HANGUL-VBASE #x1161) 5985 (defconstant HANGUL-TBASE #x11A7) 5986 5987 (defconstant HANGUL-SCOUNT 11172) 5988 (defconstant HANGUL-LCOUNT 19) 5989 (defconstant HANGUL-VCOUNT 21) 5990 (defconstant HANGUL-TCOUNT 28) 5991 (defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT)) 5992 5993 (defun combine-bmp-chars (base combiner) 5994 (if (and (char>= combiner (code-char hangul-vbase)) 5995 (char< combiner (code-char (+ hangul-tbase hangul-tcount)))) 5996 (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount))) 5997 (char>= base (code-char hangul-lbase)) 5998 (char< base (code-char (+ hangul-lbase hangul-lcount)))) 5999 (return-from combine-bmp-chars 6000 (code-char (+ hangul-lbase 6001 (* hangul-ncount (- (char-code base) hangul-lbase)) 6002 (* hangul-tcount (- (char-code combiner) hangul-vbase)))))) 6003 (if (and (char> combiner (code-char hangul-tbase)) 6004 (char>= base (code-char hangul-sbase)) 6005 (char< base (code-char (+ hangul-sbase hangul-scount)))) 6006 (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount)))) 6007 (return-from combine-bmp-chars nil) 6008 (return-from combine-bmp-chars 6009 (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase))))))) 6010 6011 (let* ((idx (search-char-vector *bmp-combining-chars* combiner)) 6012 (base-table (if idx (svref *bmp-combining-base-chars* idx)))) 6013 (if base-table 6014 (let* ((combined-idx (search-char-vector base-table base))) 6015 (if combined-idx 6016 (svref (svref *bmp-precombined-chars* idx) combined-idx)))))) 6017 6018 (defun precompose-simple-string (s) 6019 (let* ((n (length s))) 6020 (or (dotimes (i n s) 6021 (when (is-combinable (schar s i)) 6022 (return nil))) 6023 (let* ((new (make-string n))) 6024 (declare (dynamic-extent new)) 6025 (do* ((i 0 (1+ i)) 6026 (nout -1) 6027 (lastch nil)) 6028 ((= i n) (subseq new 0 (1+ nout))) 6029 (declare (fixnum nout i)) 6030 (let* ((ch (schar s i))) 6031 (if (or (not lastch) 6032 (not (is-combinable ch))) 6033 (setf lastch ch 6034 (schar new (incf nout)) ch) 6035 (let* ((combined (combine-bmp-chars lastch ch))) 6036 (if combined 6037 (setf (schar new nout) (setq lastch combined)) 6038 (setf lastch ch 6039 (schar new (incf nout)) ch)))))))))) -
branches/working-0711/ccl/level-1/linux-files.lisp
r7517 r7624 30 30 ) 31 31 32 33 (defun get-foreign-namestring (pointer) 34 ;; On Darwin, foreign namestrings are encoded in UTF-8 and 35 ;; are canonically decomposed (NFD). Use PRECOMPOSE-SIMPLE-STRING 36 ;; to ensure that the string is "precomposed" (NFC), like the 37 ;; rest of the world and most sane people would expect. 38 #+darwin-target 39 (precompose-simple-string (%get-utf-8-cstring pointer)) 40 ;; On some other platforms, the namestring is assumed to 41 ;; be encoded according to the current locale's character 42 ;; encoding (though FreeBSD seems to be moving towards 43 ;; precomposed UTF-8.). 44 ;; In any case, the use if %GET-CSTRING here is wrong ... 45 #-darwin-target 46 (%get-cstring pointer)) 32 47 33 48 (defun nanoseconds (n) … … 156 171 ((< len bufsize) 157 172 (setf (%get-unsigned-byte buf len) 0) 158 (values ( %get-cstring buf) len))173 (values (get-foreign-namestring buf) len)) 159 174 (t (values nil len))))))) 160 175 (do* ((string nil) … … 176 191 177 192 (defun %chdir (dirname) 178 ( with-cstrs ((dirname dirname))193 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname)) 179 194 (syscall syscalls::chdir dirname))) 180 195 181 196 (defun %mkdir (name mode) 182 (let* (( last (1- (length name))))183 (with-cstrs ((name name))184 (when (and (>= last 0)185 (eql (%get-byte name last) (char-code #\/)))186 (setf (%get-byte name last) 0))187 (syscall syscalls::mkdir name mode))))197 (let* ((name name) 198 (len (length name))) 199 (when (and (> len 0) (eql (char name (1- len)) #\/)) 200 (setq name (subseq name 0 (1- len)))) 201 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) 202 (syscall syscalls::mkdir name mode)))) 188 203 189 204 (defun %rmdir (name) 190 205 (let* ((last (1- (length name)))) 191 ( with-cstrs ((name name))206 (#+darwin-target with-utf8-cstrs #-darwin-target with-cstrs ((name name)) 192 207 (when (and (>= last 0) 193 208 (eql (%get-byte name last) (char-code #\/))) 194 209 (setf (%get-byte name last) 0)) 195 210 (syscall syscalls::rmdir name)))) 211 196 212 197 213 (defun getenv (key) … … 247 263 248 264 (defun %%stat (name stat) 249 ( with-cstrs ((cname name))265 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) 250 266 (%stat-values 251 267 #+linux-target … … 264 280 265 281 (defun %%lstat (name stat) 266 ( with-cstrs ((cname name))282 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) 267 283 (%stat-values 268 284 #+linux-target … … 377 393 (setq namestring (current-directory-name))) 378 394 (%stack-block ((resultbuf #$PATH_MAX)) 379 ( with-cstrs ((name (tilde-expand namestring)))395 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring #|(tilde-expand namestring)|#)) 380 396 (let* ((result (#_realpath name resultbuf))) 381 397 (declare (dynamic-extent result)) 382 398 (unless (%null-ptr-p result) 383 ( %get-cstring result))))))399 (get-foreign-namestring result)))))) 384 400 385 401 ;;; Return fully resolved pathname & file kind, or (values nil nil) … … 436 452 437 453 (defun %utimes (namestring) 438 ( with-cstrs ((cnamestring namestring))454 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring)) 439 455 (let* ((err (#_utimes cnamestring (%null-ptr)))) 440 456 (declare (fixnum err)) … … 454 470 455 471 (defun %open-dir (namestring) 456 ( with-cstrs ((name namestring))472 (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring)) 457 473 (let* ((DIR (#_opendir name))) 458 474 (unless (%null-ptr-p DIR) … … 464 480 (defun %read-dir (dir) 465 481 (let* ((res (#_readdir dir))) 466 (unless (%null-ptr-p res) 467 ( %get-cstring (pref res :dirent.d_name)))))482 (unless (%null-ptr-p res) 483 (get-foreign-namestring (pref res :dirent.d_name))))) 468 484 469 485 (defun tcgetpgrp (fd) … … 489 505 (let* ((err (#_getpwuid_r userid pwd buf buflen result))) 490 506 (if (eql 0 err) 491 (return ( %get-cstring (pref pwd :passwd.pw_dir)))507 (return (get-foreign-namestring (pref pwd :passwd.pw_dir))) 492 508 (unless (eql err #$ERANGE) 493 509 (return nil)))))))) … … 634 650 635 651 636 #+linux-target 637 (defun pipe () 638 (%stack-block ((pipes 8)) 639 (let* ((status (syscall syscalls::pipe pipes))) 640 (if (= 0 status) 641 (values (%get-long pipes 0) (%get-long pipes 4)) 642 (%errno-disp status))))) 652 643 653 644 654 645 655 ;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd. 646 656 ;;; Use libc's interface. 647 #+(or darwin-target freebsd-target)648 657 (defun pipe () 658 ;; (rlet ((filedes (:array :int 2))) 649 659 (%stack-block ((filedes 8)) 650 (let* ((status (#_pipe filedes))) 660 (let* ((status (#_pipe filedes)) 661 (errno (if (eql status 0) 0 (%get-errno)))) 662 (unless (zerop status) 663 (when (or (eql errno (- #$EMFILE)) 664 (eql errno (- #$ENFILE))) 665 (gc) 666 (drain-termination-queue) 667 (setq status (#_pipe filedes) 668 errno (if (zerop status) 0 (%get-errno))))) 651 669 (if (zerop status) 652 670 (values (paref filedes (:array :int) 0) (paref filedes (:array :int) 1)) 653 (%errno-disp (%get-errno))))))671 (%errno-disp errno))))) 654 672 655 673 … … 707 725 :element-type element-type 708 726 :interactive nil 709 :basic t) 727 :basic t 728 :auto-close t) 710 729 (cons read-pipe close-in-parent) 711 730 (cons write-pipe close-on-error))) … … 716 735 :element-type element-type 717 736 :interactive nil 718 :basic t) 737 :basic t 738 :auto-close t) 719 739 (cons write-pipe close-in-parent) 720 740 (cons read-pipe close-on-error))) … … 1191 1211 (if (eql 1 (cpu-count)) 1192 1212 (%defglobal '*spin-lock-tries* 1) 1193 (%defglobal '*spin-lock-tries* 1024))) 1213 (%defglobal '*spin-lock-tries* 1024)) 1214 (%defglobal '*spin-lock-timeouts* 0)) 1194 1215 1195 1216 (defun yield () -
branches/working-0711/ccl/level-1/sysutils.lisp
r7247 r7624 310 310 (%kernel-restart $xwrongtype arg type))) 311 311 312 ; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)312 ;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named) 313 313 (defun %require-type (arg predsym) 314 314 (if (funcall predsym arg) 315 315 arg 316 (%kernel-restart $xwrongtype arg `(satisfies ,predsym))))316 (%kernel-restart $xwrongtype arg (type-for-predicate predsym)))) 317 317 318 318 (defun %require-type-builtin (arg type-cell) … … 323 323 324 324 325 ;;; In lieu of an inverted mapping, at least try to find cases involving 326 ;;; builtin numeric types and predicates associated with them. 327 (defun type-for-predicate (pred) 328 (or (block find 329 (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype) 330 (eq (numeric-ctype-predicate ctype) 331 pred)) 332 (return-from find type))) 333 *builtin-type-info*)) 334 `(satisfies ,pred))) 325 335 326 336 -
branches/working-0711/ccl/lib/backtrace.lisp
r7594 r7624 239 239 value))))))) 240 240 241 ;;; Returns non-nil on success (not newval) 242 (defun set-map-entry-value (context cfp lfun pc idx newval) 243 (declare (fixnum pc idx)) 244 (let* ((unavailable (cons nil nil)) 245 (value (map-entry-value context cfp lfun pc idx unavailable))) 246 (if (eq value unavailable) 247 nil 248 (if (typep value 'value-cell) 249 (progn (setf (uvref value 0) newval) t) 250 251 (let* ((addrs (cdr (function-symbol-map lfun))) 252 (addr (svref addrs (the fixnum (* 3 idx))))) 253 (declare (fixnum addr)) 254 (if (= #o77 (ldb (byte 6 0) addr)) 255 (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval) 256 (set-register-argument-value context cfp addr newval)) 257 t))))) 258 259 241 260 (defun argument-value (context cfp lfun pc name &optional (quote t)) 242 261 (declare (fixnum pc)) … … 274 293 (defun raw-frame-ref (cfp context index bad) 275 294 (%raw-frame-ref cfp context index bad)) 295 296 (defun raw-frame-set (cfp context index new) 297 (%raw-frame-set cfp context index new)) 276 298 277 299 (defun find-register-argument-value (context cfp regval bad) 278 300 (%find-register-argument-value context cfp regval bad)) 301 302 (defun set-register-argument-value (context cfp regval newval) 303 (%set-register-argument-value context cfp regval newval)) 304 279 305 280 306 … … 390 416 (push i indices) 391 417 (push (svref names i) vars)))))))))) 418 419 420 (defun arg-value (context cfp lfun pc unavailable name) 421 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 422 (multiple-value-bind (valid req opt rest keys) 423 (arg-names-from-map lfun pc) 424 (if valid 425 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 426 (pos (position name vars))) 427 (if (and pos (< pos nargs)) 428 (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable) 429 unavailable)) 430 unavailable)))) 431 432 (defun local-value (context cfp lfun pc unavailable name) 433 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 434 (multiple-value-bind (valid req opt rest keys) 435 (arg-names-from-map lfun pc) 436 (if valid 437 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 438 (names (nthcdr nargs vars)) 439 (indices (nthcdr nargs map-indices)) 440 (pos (if (typep name 'unsigned-byte) 441 name 442 (position name names :from-end t)))) 443 (if (and pos (< pos nargs)) 444 (map-entry-value context cfp lfun pc (nth pos indices) unavailable) 445 unavailable)) 446 unavailable)))) 447 448 (defun set-arg-value (context cfp lfun pc name new) 449 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 450 (multiple-value-bind (valid req opt rest keys) 451 (arg-names-from-map lfun pc) 452 (if valid 453 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 454 (pos (position name vars))) 455 (when (and pos (< pos nargs)) 456 (set-map-entry-value context cfp lfun pc (nth pos map-indices) new))))))) 457 458 (defun set-local-value (context cfp lfun pc name new) 459 (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) 460 (multiple-value-bind (valid req opt rest keys) 461 (arg-names-from-map lfun pc) 462 (if valid 463 (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) 464 (names (nthcdr nargs vars)) 465 (indices (nthcdr nargs map-indices)) 466 (pos (if (typep name 'unsigned-byte) 467 name 468 (position name names :from-end t)))) 469 (if (and pos (< pos nargs)) 470 (set-map-entry-value context cfp lfun pc (nth pos indices) new))))))) 471 392 472 393 473 (defun arguments-and-locals (context cfp lfun pc &optional unavailable) … … 465 545 (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) 466 546 (setq oldest db))))) 547 548 (defun (setf oldest-binding-frame-value) (new context frame) 549 (let* ((oldest nil) 550 (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) 551 (do* ((db (db-link context) (%fixnum-ref db 0))) 552 ((eq frame db) 553 (if oldest 554 (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new) 555 (let* ((symbol (binding-index-symbol binding-index))) 556 (if context 557 (setf (symbol-value-in-tcr symbol (bt.tcr context)) new) 558 (%set-sym-value symbol new))))) 559 (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) 560 (setq oldest db))))) 467 561 468 562 -
branches/working-0711/ccl/lib/ccl-export-syms.lisp
r7330 r7624 143 143 ensure-class-using-class 144 144 ensure-generic-function-using-class 145 eql-specializer 145 146 eql-specializer-object 146 147 extract-lambda-list … … 221 222 specializer-direct-generic-functions 222 223 copy-instance 224 225 override-one-method-one-arg-dcode 226 optimize-generic-function-dispatching 223 227 224 228 ;; Not MOP … … 651 655 "ENSURE-CLASS-USING-CLASS" 652 656 "ENSURE-GENERIC-FUNCTION-USING-CLASS" 657 "EQL-SPECIALIZER" 653 658 "EQL-SPECIALIZER-OBJECT" 654 659 "EXTRACT-LAMBDA-LIST" -
branches/working-0711/ccl/lib/compile-ccl.lisp
r6979 r7624 193 193 arglist 194 194 edit-callers 195 hash-cons196 195 describe 197 196 asdf -
branches/working-0711/ccl/lib/describe.lisp
r7554 r7624 1546 1546 *backtrace-internal-functions*)) 1547 1547 (break-condition :accessor break-condition 1548 :initarg :break-condition))) 1548 :initarg :break-condition) 1549 (unavailable-value-marker :initform (cons nil nil) 1550 :accessor unavailable-value-marker))) 1549 1551 1550 1552 … … 1561 1563 (defmethod compute-frame-info ((f error-frame) n) 1562 1564 (let* ((frame (svref (addresses f) n)) 1563 (context (context f))) 1565 (context (context f)) 1566 (marker (unavailable-value-marker f))) 1567 1564 1568 (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame) 1565 (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc )1569 (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker) 1566 1570 (list (ccl::arglist-from-map lfun) args locals))))) 1567 1571 -
branches/working-0711/ccl/lib/foreign-types.lisp
r6503 r7624 1700 1700 (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)) 1701 1701 (canonicalize-foreign-type-ordinal '(:* (:struct :hostent))) 1702 (canonicalize-foreign-type-ordinal '(:array :int 2)) 1702 1703 ))) 1703 1704 -
branches/working-0711/ccl/lib/hash.lisp
r2584 r7624 159 159 ':test (hash-table-test table) 160 160 (hash-table-count table) 161 (hash-table-size table)))) 161 (hash-table-size table)) 162 (when (readonly-hash-table-p table) 163 (format stream " (Readonly)")))) 162 164 163 165 … … 209 211 210 212 (defun start-hash-table-iterator (hash state) 211 (let (vector )213 (let (vector locked) 212 214 (unless (hash-table-p hash) 213 215 (setf (hti.hash-table state) nil) ; for finish-hash-table-iterator … … 216 218 (without-interrupts 217 219 (setf (hti.hash-table state) hash) 218 ( lock-hash-table hash)219 ( %lock-gc-lock)220 (setf (hti.lock state) (setq locked (not (eq :readonly (lock-hash-table-for-map hash))))) 221 (when locked (%lock-gc-lock)) 220 222 (setq vector (nhash.vector hash)) 221 223 (setf (hti.vector state) vector) … … 254 256 (defun finish-hash-table-iterator (state) 255 257 (without-interrupts 256 (let ((hash (hti.hash-table state))) 258 (let ((hash (hti.hash-table state)) 259 (locked (hti.lock state))) 257 260 (when hash 258 261 (setf (hti.hash-table state) nil) 259 (unlock-hash-table hash) 260 (%unlock-gc-lock) 262 (when locked 263 (unlock-hash-table hash nil) 264 (%unlock-gc-lock)) 261 265 (when (eq state (nhash.iterator hash)) 262 266 (setf (nhash.iterator hash) (hti.prev-iterator state))) -
branches/working-0711/ccl/lib/macros.lisp
r7449 r7624 1493 1493 ,@body))) 1494 1494 1495 (defmacro with-self-bound-io-control-vars (&body body) 1496 `(let ( 1497 (*print-array* *print-array*) 1498 (*print-base* *print-base*) 1499 (*print-case* *print-case*) 1500 (*print-circle* *print-circle*) 1501 (*print-escape* *print-escape*) 1502 (*print-gensym* *print-gensym*) 1503 (*print-length* *print-length*) 1504 (*print-level* *print-level*) 1505 (*print-lines* *print-lines*) 1506 (*print-miser-width* *print-miser-width*) 1507 (*print-pprint-dispatch* *print-pprint-dispatch*) 1508 (*print-pretty* *print-pretty*) 1509 (*print-radix* *print-radix*) 1510 (*print-readably* *print-readably*) 1511 (*print-right-margin* *print-right-margin*) 1512 (*read-base* *read-base*) 1513 (*read-default-float-format* *read-default-float-format*) 1514 (*read-eval* *read-eval*) 1515 (*read-suppress* *read-suppress*) 1516 (*readtable* *readtable*)) 1517 ,@body)) 1518 1495 1519 (defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms) 1496 1520 "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally … … 1580 1604 `(%cstr-pointer ,strname ,sym)) 1581 1605 ,@body)))))) 1606 1607 (defmacro with-utf-8-cstr ((sym str) &body body) 1608 (let* ((data (gensym)) 1609 (offset (gensym)) 1610 (string (gensym)) 1611 (len (gensym)) 1612 (noctets (gensym)) 1613 (end (gensym))) 1614 `(let* ((,string ,str) 1615 (,len (length ,string))) 1616 (multiple-value-bind (,data ,offset) (array-data-and-offset ,string) 1617 (let* ((,end (+ ,offset ,len)) 1618 (,noctets (utf-8-octets-in-string ,data ,offset ,end))) 1619 (%stack-block ((,sym (1+ ,noctets))) 1620 (utf-8-memory-encode ,data ,sym 0 ,offset ,end) 1621 (setf (%get-unsigned-byte ,sym ,noctets) 0) 1622 ,@body)))))) 1582 1623 1583 1624 … … 2907 2948 (setf (,accessor ,dst ,i) (,accessor ,src ,i)))))) 2908 2949 2909 2950 (defmacro assert-pointer-type (pointer type) 2951 "Assert that the pointer points to an instance of the specified foreign type. 2952 Return the pointer." 2953 (let* ((ptr (gensym))) 2954 `(let* ((,ptr ,pointer)) 2955 (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type)))) 2956 ,ptr))) 2957 2910 2958 2911 2959 … … 2988 3036 ,@body) 2989 3037 (%unlock-gc-lock))) 3038 3039 (defmacro with-deferred-gc (&body body) 3040 "Execute BODY without responding to the signal used to suspend 3041 threads for GC. BODY must be very careful not to do anything which 3042 could cause an exception (note that attempting to allocate lisp memory 3043 may cause an exception.)" 3044 `(let* ((*interrupt-level* -2)) 3045 ,@body)) 3046 3047 (defmacro allowing-deferred-gc (&body body) 3048 "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC." 3049 `(let* ((*interrupt-level* -1)) 3050 (%check-deferred-gc) 3051 ,@body)) 3052 3053 2990 3054 2991 3055 (defmacro with-pointer-to-ivector ((ptr ivector) &body body) -
branches/working-0711/ccl/lib/misc.lisp
r7278 r7624 712 712 (when (and line (parse-integer line :junk-allowed t) ) 713 713 (return-from local-svn-revision line))))))))) 714 715 716 ;;; Scan the heap, collecting infomation on the primitive object types 717 ;;; found. Report that information. 718 719 (defun heap-utilization (&key (stream *debug-io*) 720 (gc-first t)) 721 (let* ((nconses 0) 722 (nvectors (make-array 256)) 723 (vector-sizes (make-array 256)) 724 (array-size-function (arch::target-array-data-size-function 725 (backend-target-arch *host-backend*)))) 726 (declare (type (simple-vector 256) nvectors vector-sizes) 727 (dynamic-extent nvectors vector-sizes)) 728 (when gc-first (gc)) 729 (%map-areas (lambda (thing) 730 (if (consp thing) 731 (incf nconses) 732 (let* ((typecode (typecode thing))) 733 (incf (aref nvectors typecode)) 734 (incf (aref vector-sizes typecode) 735 (funcall array-size-function typecode (uvsize thing))))))) 736 (report-heap-utilization stream nconses nvectors vector-sizes) 737 (values))) 738 739 #+x8664-target 740 (progn 741 (defvar *x8664-vector-type-names* 742 (let* ((a (make-array 256))) 743 (dotimes (i 256 a) 744 (let* ((fulltag (logand i x8664::fulltagmask)) 745 (names-vector 746 (cond ((= fulltag x8664::fulltag-nodeheader-0) 747 *nodeheader-0-types*) 748 ((= fulltag x8664::fulltag-nodeheader-1) 749 *nodeheader-1-types*) 750 ((= fulltag x8664::fulltag-immheader-0) 751 *immheader-0-types*) 752 ((= fulltag x8664::fulltag-immheader-1) 753 *immheader-1-types*) 754 ((= fulltag x8664::fulltag-immheader-2) 755 *immheader-2-types*))) 756 (name (if names-vector 757 (aref names-vector (ash i -4))))) 758 ;; Special-case a few things ... 759 (if (eq name 'symbol-vector) 760 (setq name 'symbol) 761 (if (eq name 'function-vector) 762 (setq name 'function))) 763 (setf (aref a i) name))))) 764 765 766 (defun report-heap-utilization (out nconses nvectors vector-sizes) 767 (format out "~&Object type~42tCount~50tTotal Size in Bytes") 768 (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size)) 769 (dotimes (i (length nvectors)) 770 (let* ((count (aref nvectors i)) 771 (sizes (aref vector-sizes i))) 772 (unless (zerop count) 773 (format out "~&~a~36t~12d~48t~16d" (aref *x8664-vector-type-names* i) count sizes))))) 774 775 ) 776 777 #-x8664-target 778 (eval-when (:compile-toplevel) 779 (warn "Need PPC versions of REPORT-HEAP-UTILIZATION")) 780 -
branches/working-0711/ccl/lib/numbers.lisp
r6012 r7624 350 350 (defparameter a-short-float 1.0s0) 351 351 352 352 #+32-bit-target 353 353 (defmethod print-object ((rs random-state) stream) 354 354 (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! 355 355 'ccl::initialize-random-state 356 (%svref rs 1) 357 (%svref rs 2))) 356 (random.seed-1 rs) 357 (random.seed-2 rs))) 358 359 #+64-bit-target 360 (defmethod print-object ((rs random-state) stream) 361 (let* ((s1 (random.seed-1 rs))) 362 (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! 363 'ccl::initialize-random-state 364 (ldb (byte 16 16) s1) 365 (ldb (byte 16 0) s1)))) 358 366 359 367 -
branches/working-0711/ccl/lib/ppc-backtrace.lisp
r6925 r7624 250 250 (get-register-value nil last-catch index))) 251 251 252 (defun %set-register-argument-value (context cfp regval new) 253 (let* ((last-catch (last-catch-since cfp context)) 254 (index (register-number->saved-register-index regval))) 255 (do* ((frame cfp 256 (child-frame frame context)) 257 (first t)) 258 ((null frame)) 259 (if (fake-stack-frame-p frame) 260 (return-from %set-register-argument-value 261 (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new)) 262 (if first 263 (setq first nil) 264 (multiple-value-bind (lfun pc) 265 (cfp-lfun frame) 266 (when lfun 267 (multiple-value-bind (mask where) 268 (registers-used-by lfun pc) 269 (when (if mask (logbitp index mask)) 270 (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) 271 (return-from 272 %set-register-argument-value 273 (raw-frame-set frame context where new))))))))) 274 (set-register-value new nil last-catch index))) 275 252 276 (defun %raw-frame-ref (cfp context idx bad) 253 277 (declare (fixnum idx)) … … 273 297 bad)))) 274 298 299 (defun %raw-frame-set (cfp context idx new) 300 (declare (fixnum idx)) 301 (multiple-value-bind (frame base) 302 (vsp-limits cfp context) 303 (let* ((raw-size (- base frame))) 304 (declare (fixnum frame base raw-size)) 305 (if (and (>= idx 0) 306 (< idx raw-size)) 307 (let* ((addr (- (the fixnum (1- base)) 308 idx))) 309 (multiple-value-bind (db-count first-db last-db) 310 (count-db-links-in-frame frame base context) 311 (let* ((is-db-link 312 (unless (zerop db-count) 313 (do* ((last last-db (previous-db-link last first-db))) 314 ((null last)) 315 (when (= addr last) 316 (return t)))))) 317 (if is-db-link 318 (setf (oldest-binding-frame-value context addr) new) 319 (setf (%fixnum-ref addr) new)))) 320 t))))) 321 275 322 ;;; Used for printing only. 276 323 (defun index->address (p) -
branches/working-0711/ccl/lib/systems.lisp
r5738 r7624 181 181 182 182 (edit-callers "ccl:bin;edit-callers" ("ccl:lib;edit-callers.lisp")) 183 (hash-cons "ccl:library;hash-cons" ("ccl:library;hash-cons.lisp"))184 ; (step "ccl:bin;step" ("ccl:lib;step.lisp"))183 ;; (hash-cons "ccl:library;hash-cons" ("ccl:library;hash-cons.lisp")) 184 ;; (step "ccl:bin;step" ("ccl:lib;step.lisp")) 185 185 (ccl-export-syms "ccl:bin;ccl-export-syms" ("ccl:lib;ccl-export-syms.lisp")) 186 186 (systems "ccl:bin;systems" ("ccl:lib;systems.lisp")) -
branches/working-0711/ccl/lib/x86-backtrace.lisp
r7224 r7624 95 95 bad))) 96 96 97 (defun %raw-frame-set (frame context idx new) 98 (declare (fixnum frame idx)) 99 (let* ((base (parent-frame frame context)) 100 (raw-size (- base frame))) 101 (declare (fixnum base raw-size)) 102 (if (and (>= idx 0) 103 (< idx raw-size)) 104 (let* ((addr (- (the fixnum (1- base)) 105 idx))) 106 (multiple-value-bind (db-count first-db last-db) 107 (count-db-links-in-frame frame base context) 108 (let* ((is-db-link 109 (unless (zerop db-count) 110 (do* ((last last-db (previous-db-link last first-db))) 111 ((null last)) 112 (when (= addr last) 113 (return t)))))) 114 (if is-db-link 115 (setf (oldest-binding-frame-value context addr) new) 116 (setf (%fixnum-ref addr) new)))))))) 117 97 118 (defun %stack< (index1 index2 &optional context) 98 119 (let* ((tcr (if context (bt.tcr context) (%current-tcr))) … … 153 174 (get-register-value nil last-catch index))) 154 175 176 (defun %set-register-argument-value (context cfp regval new) 177 (let* ((last-catch (last-catch-since cfp context)) 178 (index (register-number->saved-register-index regval))) 179 (do* ((frame cfp (child-frame frame context)) 180 (first t)) 181 ((null frame)) 182 (if (xcf-p frame) 183 (with-macptrs (xp) 184 (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp)) 185 (return-from %set-register-argument-value 186 (setf (encoded-gpr-lisp xp regval) new))) 187 (progn 188 (unless first 189 (multiple-value-bind (lfun pc) 190 (cfp-lfun frame) 191 (when lfun 192 (multiple-value-bind (mask where) 193 (registers-used-by lfun pc) 194 (when (if mask (logbitp index mask)) 195 (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) 196 197 (return-from %set-register-argument-value 198 (raw-frame-set frame context where new))))))) 199 (setq first nil)))) 200 (set-register-value new nil last-catch index))) 201 155 202 ;;; Used for printing only. 156 203 (defun index->address (p) -
branches/working-0711/ccl/library/lispequ.lisp
r6913 r7624 1223 1223 nhash.find ; function: find vector-index 1224 1224 nhash.find-new ; function: find vector-index on put 1225 nhash.read-only ; boolean: true when read-only 1225 1226 ) 1226 1227 -
branches/working-0711/ccl/library/x8664-linux-syscalls.lisp
r4052 r7624 150 150 151 151 152 (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::futex 202 (:address :signed-fullword :signed-fullword :address :address :signed-fullword) :signed-fullword ) 152 153 153 154 #+notdefinedyet -
branches/working-0711/ccl/lisp-kernel/Threads.h
r6260 r7624 47 47 #include "gc.h" 48 48 49 #ifdef USE_FUTEX 50 #include <linux/futex.h> 51 #include <sys/syscall.h> 52 #endif 53 54 #include <syslog.h> 55 49 56 Boolean extern threads_initialized; 57 Boolean extern log_tcr_info; 58 59 #define LOCK_SPINLOCK(x,tcr) get_spin_lock(&(x),tcr) 60 #define RELEASE_SPINLOCK(x) (x)=0 50 61 51 62 #define TCR_TO_TSD(tcr) ((void *)((natural)(tcr)+TCR_BIAS)) … … 56 67 #define SEM_WAIT(s) sem_wait((SEMAPHORE)s) 57 68 #define SEM_RAISE(s) sem_post((SEMAPHORE)s) 69 #define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0) 58 70 #define SEM_TIMEDWAIT(s,t) sem_timedwait((SEMAPHORE)s,(struct timespec *)t) 59 71 #endif … … 63 75 #define SEM_WAIT(s) semaphore_wait((SEMAPHORE)(natural)s) 64 76 #define SEM_RAISE(s) semaphore_signal((SEMAPHORE)(natural)s) 77 #define SEM_BROADCAST(s,count)semaphore_signal_all((SEMAPHORE)(natural)s) 65 78 #define SEM_TIMEDWAIT(s,t) semaphore_timedwait((SEMAPHORE)(natural)s,t) 66 79 #endif … … 121 134 Boolean resume_tcr(TCR *); 122 135 123 typedef struct _rwquentry124 {125 struct _rwquentry *prev;126 struct _rwquentry *next;127 TCR *tcr;128 int count;129 } rwquentry;130 131 136 typedef struct 132 137 { 133 rwquentry head; 134 int state; /* sum of all counts on queue */ 135 pthread_mutex_t *lock; /* lock access to this data structure */ 136 pthread_cond_t *reader_signal; 137 pthread_cond_t *writer_signal; 138 int write_wait_count; 139 int read_wait_count; 140 int dying; 141 rwquentry freelist; 138 signed_natural spin; /* need spin lock to change fields */ 139 signed_natural state; /* 0 = free, positive if writer, negative if readers; */ 140 natural blocked_writers; 141 natural blocked_readers; 142 TCR *writer; 143 #ifdef USE_FUTEX 144 natural reader_signal; 145 natural writer_signal; 146 #else 147 void * reader_signal; 148 void * writer_signal; 149 #endif 150 void *malloced_ptr; 142 151 } rwlock; 143 152 144 #define RWLOCK_WRITER(rw) rw->head.tcr145 #define RWLOCK_WRITE_COUNT(rw) rw->head.count146 153 147 154 rwlock * rwlock_new(void); 148 intrwlock_destroy(rwlock *);155 void rwlock_destroy(rwlock *); 149 156 int rwlock_rlock(rwlock *, TCR *, struct timespec *); 150 157 int rwlock_wlock(rwlock *, TCR *, struct timespec *); 151 158 int rwlock_try_wlock(rwlock *, TCR *); 159 int rwlock_try_rlock(rwlock *, TCR *); 152 160 int rwlock_unlock(rwlock *, TCR *); 153 161 -
branches/working-0711/ccl/lisp-kernel/errors.s
r6899 r7624 25 25 error_excised_function_call = 6 26 26 error_too_many_values = 7 27 error_propagate_suspend = 10 27 28 error_cant_call = 17 28 29 -
branches/working-0711/ccl/lisp-kernel/gc.h
r7137 r7624 118 118 #define GC_TRAP_FUNCTION_EGC_CONTROL 32 119 119 #define GC_TRAP_FUNCTION_CONFIGURE_EGC 64 120 #define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 120 #define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 /* deprecated */ 121 #define GC_TRAP_FUNCTION_FREEZE 129 122 #define GC_TRAP_FUNCTION_THAW 130 123 121 124 #endif /* __GC_H__ */ -
branches/working-0711/ccl/lisp-kernel/image.c
r6215 r7624 211 211 212 212 a->static_dnodes = sect->static_dnodes; 213 if (a->static_dnodes) {214 natural pages_size = (align_to_power_of_2((align_to_power_of_2(a->static_dnodes,215 log2_nbits_in_word)>>3),216 log2_page_size));217 lseek(fd,pos+mem_size, SEEK_SET);218 pos = seek_to_next_page(fd);219 addr = mmap(NULL,220 pages_size,221 PROT_READ | PROT_WRITE,222 MAP_PRIVATE,223 fd,224 pos);225 if (addr == MAP_FAILED) {226 return;227 }228 a->static_used = addr;229 advance = pages_size;230 }231 213 sect->area = a; 232 214 break; … … 420 402 #endif 421 403 422 areas[0] = readonly_area;423 areas[1] = nilreg_area;424 areas[2] = active_dynamic_area;404 areas[0] = nilreg_area; 405 areas[1] = active_dynamic_area; 406 areas[2] = readonly_area; 425 407 areas[3] = managed_static_area; 426 408 for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { … … 477 459 case FWDNUM: 478 460 case GC_NUM: 479 case DELETED_STATIC_PAIRS:461 case STATIC_CONSES: 480 462 break; 481 463 default: … … 503 485 return errno; 504 486 } 505 if (nstatic) {506 /* Need to write the static_used bitmap */507 natural static_used_size_in_bytes =508 (align_to_power_of_2((align_to_power_of_2(nstatic, log2_nbits_in_word)>>3),509 log2_page_size));510 seek_to_next_page(fd);511 if (write(fd, tenured_area->static_used, static_used_size_in_bytes)512 != static_used_size_in_bytes) {513 return errno;514 }515 }516 487 } 517 488 } -
branches/working-0711/ccl/lisp-kernel/lisp-errors.h
r5529 r7624 18 18 #define __ERRORS_X 1 19 19 20 /*21 10/22/96 bill error_too_many_values22 --- 4.0 ---23 05/12/96 gb conditionalize on __ERRORS_X to avoid conflict with <errors.h>24 --- 3.9 ---25 04/10/96 gb error_memory_full26 04/09/96 gb error_excised_function_call27 03/01/96 gb FPU exceptions28 01/22/96 gb add/rename error_alloc_failed, error_stack_overflow29 12/13/95 gb add error_alloc_fail, error_throw_tag_missing.30 11/09/95 gb in synch with %type-error-types%.31 */32 20 33 21 #define error_reg_regnum 0 … … 39 27 #define error_excised_function_call 6 40 28 #define error_too_many_values 7 29 #define error_propagate_suspend 10 41 30 #define error_cant_call 17 42 31 -
branches/working-0711/ccl/lisp-kernel/lisp_globals.h
r6901 r7624 33 33 #define TCR_AREA_LOCK (-11) /* all_areas/tcr queue lock */ 34 34 #define EXCEPTION_LOCK (-12) /* serialize exception handling */ 35 #define DELETED_STATIC_PAIRS (-13) /* for hash-consing */35 #define STATIC_CONSES (-13) 36 36 #define DEFAULT_ALLOCATION_QUANTUM (-14) 37 37 #define INTFLAG (-15) -
branches/working-0711/ccl/lisp-kernel/ppc-constants.h
r3493 r7624 68 68 #define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4) 69 69 #define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) 70 #define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) 71 #define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) 70 72 71 73 #define TCR_STATE_FOREIGN (1) -
branches/working-0711/ccl/lisp-kernel/ppc-constants32.s
r5783 r7624 607 607 TCR_FLAG_BIT_FOREIGN = fixnum_shift 608 608 TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) 609 TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) 610 TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) 611 TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) 612 TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) 613 TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) 614 TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) 609 615 610 616 r0 = 0 -
branches/working-0711/ccl/lisp-kernel/ppc-constants64.s
r5783 r7624 577 577 578 578 TCR_FLAG_BIT_FOREIGN = fixnum_shift 579 TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) 579 TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) 580 TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) 581 TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) 582 TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) 583 TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) 584 TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) 585 TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) 580 586 581 587 -
branches/working-0711/ccl/lisp-kernel/ppc-exceptions.c
r7137 r7624 1327 1327 1328 1328 case UUO_INTERR: 1329 status = handle_error(xp, errnum, rb, 0, where); 1329 if (errnum == error_propagate_suspend) { 1330 status = 0; 1331 } else { 1332 status = handle_error(xp, errnum, rb, 0, where); 1333 } 1330 1334 break; 1331 1335 … … 1759 1763 old_valence = prepare_to_wait_for_exception_lock(tcr, context); 1760 1764 } 1765 1766 if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) { 1767 CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND); 1768 pthread_kill(pthread_self(), thread_suspend_signal); 1769 } 1770 1761 1771 1762 1772 wait_for_exception_lock_in_handler(tcr, context, &xframe_link); -
branches/working-0711/ccl/lisp-kernel/ppc-gc.c
r7137 r7624 1597 1597 1598 1598 case xmacptr_flag_rwlock: 1599 rwlock_destroy((rwlock *)ptr_from_lispobj(ptr)); 1599 1600 break; 1600 1601 -
branches/working-0711/ccl/lisp-kernel/ppc-macros.s
r6515 r7624 826 826 define([aligned_bignum_size],[((~(dnode_size-1)&(node_size+(dnode_size-1)+(4*$1))))]) 827 827 828 829 828 define([suspend_now],[ 829 uuo_interr(error_propagate_suspend,rzero) 830 ]) -
branches/working-0711/ccl/lisp-kernel/ppc-spentry.s
r6903 r7624 6682 6682 /* any interrupt polling */ 6683 6683 6684 _spentry(unbind_interrupt_level) 6685 __(ldr(imm2,tcr.tlb_pointer(rcontext))) 6684 _spentry(unbind_interrupt_level) 6685 __(ldr(imm0,tcr.flags(rcontext))) 6686 __(ldr(imm2,tcr.tlb_pointer(rcontext))) 6687 __(andi. imm0,imm0,1<<TCR_FLAG_BIT_PENDING_SUSPEND) 6686 6688 __(ldr(imm1,tcr.db_link(rcontext))) 6687 6689 __(ldr(temp1,INTERRUPT_LEVEL_BINDING_INDEX(imm2))) 6688 __(cmpri(cr1,temp1,0)) 6690 __(bne 5f) 6691 0: __(cmpri(cr1,temp1,0)) 6689 6692 __(ldr(temp1,binding.val(imm1))) 6690 6693 __(ldr(imm1,binding.link(imm1))) … … 6698 6701 __(mr nargs,imm2) 6699 6702 __(blr) 6703 5: /* Missed a suspend request; force suspend now if we're restoring 6704 interrupt level to -1 or greater */ 6705 __(cmpri(temp1,-2<<fixnumshift)) 6706 __(bne 0b) 6707 __(ldr(imm0,binding.val(imm1))) 6708 __(cmpr(imm0,temp1)) 6709 __(beq 0b) 6710 __(li imm0,1<<fixnumshift) 6711 __(str(imm0,INTERRUPT_LEVEL_BINDING_INDEX(imm2))) 6712 __(suspend_now()) 6713 __(b 0b) 6714 6700 6715 6701 6716 /* arg_x = array, arg_y = i, arg_z = j. Typecheck everything. -
branches/working-0711/ccl/lisp-kernel/thread_manager.c
r6904 r7624 44 44 atomic_swap(signed_natural*, signed_natural); 45 45 46 #ifdef USE_FUTEX 47 #define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val) 48 #define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n) 49 #define FUTEX_AVAIL (0) 50 #define FUTEX_LOCKED (1) 51 #define FUTEX_CONTENDED (2) 52 #endif 46 53 47 54 int … … 87 94 88 95 96 #ifndef USE_FUTEX 89 97 int spin_lock_tries = 1; 90 98 … … 103 111 } 104 112 } 105 106 113 #endif 114 115 #ifndef USE_FUTEX 107 116 int 108 117 lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) … … 117 126 } 118 127 while (1) { 119 get_spin_lock(&(m->spinlock),tcr);128 LOCK_SPINLOCK(m->spinlock,tcr); 120 129 ++m->avail; 121 130 if (m->avail == 1) { 122 131 m->owner = tcr; 123 132 m->count = 1; 124 m->spinlock = 0;133 RELEASE_SPINLOCK(m->spinlock); 125 134 break; 126 135 } 127 m->spinlock = 0;136 RELEASE_SPINLOCK(m->spinlock); 128 137 SEM_WAIT_FOREVER(m->signal); 129 138 } … … 131 140 } 132 141 133 142 #else /* USE_FUTEX */ 143 144 static void inline 145 lock_futex(natural *p) 146 { 147 148 while (1) { 149 if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) { 150 return; 151 } 152 while (1) { 153 if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) { 154 return; 155 } 156 futex_wait(p,FUTEX_CONTENDED); 157 } 158 } 159 } 160 161 static void inline 162 unlock_futex(natural *p) 163 { 164 if (atomic_decf(p) != FUTEX_AVAIL) { 165 *p = FUTEX_AVAIL; 166 futex_wake(p,INT_MAX); 167 } 168 } 169 170 int 171 lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) 172 { 173 natural val; 174 if (tcr == NULL) { 175 tcr = get_tcr(true); 176 } 177 if (m->owner == tcr) { 178 m->count++; 179 return 0; 180 } 181 lock_futex(&m->avail); 182 m->owner = tcr; 183 m->count = 1; 184 return 0; 185 } 186 #endif /* USE_FUTEX */ 187 188 189 #ifndef USE_FUTEX 134 190 int 135 191 unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) … … 144 200 --m->count; 145 201 if (m->count == 0) { 146 get_spin_lock(&(m->spinlock),tcr);202 LOCK_SPINLOCK(m->spinlock,tcr); 147 203 m->owner = NULL; 148 204 pending = m->avail-1 + m->waiting; /* Don't count us */ … … 154 210 m->waiting = 0; 155 211 } 156 m->spinlock = 0;212 RELEASE_SPINLOCK(m->spinlock); 157 213 if (pending >= 0) { 158 214 SEM_RAISE(m->signal); … … 163 219 return ret; 164 220 } 221 #else /* USE_FUTEX */ <