Index: /branches/event-ide/ccl/.cvsignore =================================================================== --- /branches/event-ide/ccl/.cvsignore (revision 8261) +++ /branches/event-ide/ccl/.cvsignore (revision 8262) @@ -8,2 +8,3 @@ README* *~.* +*.app Index: /branches/event-ide/ccl/compiler/PPC/PPC32/ppc32-arch.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/PPC32/ppc32-arch.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/PPC32/ppc32-arch.lisp (revision 8262) @@ -323,4 +323,6 @@ writer ;tcr of owning thread or 0 name + whostate + whostate-2 ) @@ -470,4 +472,15 @@ malloced-ptr spinlock) + +(define-storage-layout rwlock 0 + spin + state + blocked-writers + blocked-readers + writer + reader-signal + writer-signal + malloced-ptr + ) ;;; For the eabi port: mark this stack frame as Lisp's (since EABI @@ -910,3 +923,5 @@ ,@body))) +(defconstant arg-check-trap-pc-limit 8) + (provide "PPC32-ARCH") Index: /branches/event-ide/ccl/compiler/PPC/PPC32/ppc32-vinsns.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/PPC32/ppc32-vinsns.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/PPC32/ppc32-vinsns.lisp (revision 8262) @@ -3733,5 +3733,5 @@ (defmacro define-ppc32-subprim-jump-vinsn ((name &rest other-attrs) spno) - `(define-ppc32-vinsn (,name :jump :jumpLR ,@other-attrs) (() ()) + `(define-ppc32-vinsn (,name :jumpLR ,@other-attrs) (() ()) (ba ,spno))) @@ -3866,5 +3866,5 @@ ;;; really known, it should probably be inlined (stack-cleanup, value ;;; transfer & jump ...) -(define-ppc32-vinsn (throw :jump :jump-unknown) (() +(define-ppc32-vinsn (throw :jump-unknown) (() ()) (bla .SPthrow)) Index: /branches/event-ide/ccl/compiler/PPC/PPC64/ppc64-arch.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/PPC64/ppc64-arch.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/PPC64/ppc64-arch.lisp (revision 8262) @@ -395,4 +395,6 @@ writer ;tcr of owning thread or 0 name + whostate + whostate-2 ) @@ -548,4 +550,15 @@ malloced-ptr spinlock) + +(define-storage-layout rwlock 0 + spin + state + blocked-writers + blocked-readers + writer + reader-signal + writer-signal + malloced-ptr + ) ;;; For the eabi port: mark this stack frame as Lisp's (since EABI @@ -978,5 +991,5 @@ ,@body))) - +(defconstant arg-check-trap-pc-limit 8) (provide "PPC64-ARCH") Index: /branches/event-ide/ccl/compiler/PPC/PPC64/ppc64-vinsns.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/PPC64/ppc64-vinsns.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/PPC64/ppc64-vinsns.lisp (revision 8262) @@ -3721,5 +3721,5 @@ (defmacro define-ppc64-subprim-jump-vinsn ((name &rest other-attrs) spno) - `(define-ppc64-vinsn (,name :jump :jumpLR ,@other-attrs) (() ()) + `(define-ppc64-vinsn (,name :jumpLR ,@other-attrs) (() ()) (ba ,spno))) @@ -3850,5 +3850,5 @@ ;;; really known, it should probably be inlined (stack-cleanup, value ;;; transfer & jump ...) -(define-ppc64-vinsn (throw :jump :jump-unknown) (() +(define-ppc64-vinsn (throw :jump-unknown) (() ()) (bla .SPthrow)) Index: /branches/event-ide/ccl/compiler/PPC/ppc-arch.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/ppc-arch.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/ppc-arch.lisp (revision 8262) @@ -237,5 +237,5 @@ area-lock ; serialize access to gc exception-lock ; serialize exception handling - deleted-static-pairs ; for hash-consing + static-conses ; when FREEZE is in effect default-allocation-quantum ; log2_heap_segment_size, as a fixnum. intflag ; interrupt-pending flag Index: /branches/event-ide/ccl/compiler/PPC/ppc-lapmacros.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/ppc-lapmacros.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/ppc-lapmacros.lisp (revision 8262) @@ -175,4 +175,9 @@ (:ppc32 `(slwi ,@args)) (:ppc64 `(sldi ,@args)))) + +(defppclapmacro slri. (&rest args) + (target-arch-case + (:ppc32 `(slwi. ,@args)) + (:ppc64 `(sldi. ,@args)))) (defppclapmacro srr (&rest args) Index: /branches/event-ide/ccl/compiler/PPC/ppc2.lisp =================================================================== --- /branches/event-ide/ccl/compiler/PPC/ppc2.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/PPC/ppc2.lisp (revision 8262) @@ -41,5 +41,5 @@ (if (eq (acode-operator x) (%nx1-operator immediate)) (cadr x) - (error "~&Bug: not an immediate: ~s" x))) + (compiler-bug "~&Bug: not an immediate: ~s" x))) (defmacro with-ppc-p2-declarations (declsform &body body) @@ -237,5 +237,5 @@ ((eq cell bottom) res) (if (null cell) - (error "Horrible compiler bug.") + (compiler-bug "Horrible compiler bug.") (if (eq (lcell-kind cell) kind) (push cell res))))) @@ -570,5 +570,5 @@ (if lap-label (lap-label-address lap-label) - (error "Missing or bad ~s label: ~s" + (compiler-bug "Missing or bad ~s label: ~s" (if start-p 'start 'end) sym))))) (destructuring-bind (var sym startlab endlab) info @@ -1008,10 +1008,10 @@ (ppc2-form seg nil nil f )) (apply fn seg vreg xfer (%cdr form))) - (error "ppc2-form ? ~s" form)))))) + (compiler-bug "ppc2-form ? ~s" form)))))) ;;; dest is a float reg - form is acode (defun ppc2-form-float (seg freg xfer form) (declare (ignore xfer)) - (when (or (nx-null form)(nx-t form))(error "ppc2-form to freg ~s" form)) + (when (or (nx-null form)(nx-t form))(compiler-bug "ppc2-form to freg ~s" form)) (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double) (ppc2-form-typep form 'double-float)) @@ -1022,5 +1022,5 @@ (setq fn (svref *ppc2-specials* (%ilogand #.operator-id-mask (acode-operator form))))) (apply fn seg freg nil (%cdr form)) - (error "ppc2-form ? ~s" form)))) + (compiler-bug "ppc2-form ? ~s" form)))) @@ -1144,5 +1144,5 @@ (defun ppc2-set-NARGS (seg n) (if (> n call-arguments-limit) - (error "~s exceeded." call-arguments-limit) + (compiler-bug "~s exceeded." call-arguments-limit) (with-ppc-local-vinsn-macros (seg) (! set-nargs n)))) @@ -1274,5 +1274,5 @@ (with-ppc-local-vinsn-macros (seg) (if (target-arch-case - (:ppc32 (error "Bug!")) + (:ppc32 (compiler-bug "Bug!")) (:ppc64 *ppc2-open-code-inline*)) (! s64->integer node-dest s64-src) @@ -1298,5 +1298,5 @@ (with-ppc-local-vinsn-macros (seg) (if (target-arch-case - (:ppc32 (error "Bug!")) + (:ppc32 (compiler-bug "Bug!")) (:ppc64 *ppc2-open-code-inline*)) (! u64->integer node-dest u64-src) @@ -2355,5 +2355,5 @@ (when tail-p #-no-compiler-bugs - (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (error "Well, well, well. How could this have happened ?")) + (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well. How could this have happened ?")) (when a-reg (ppc2-copy-register seg destreg a-reg)) @@ -2752,5 +2752,5 @@ ($ ppc::arg_z) (make-wired-lreg ppc::imm0 :mode mode))) - (t (error "Unknown register class for reg ~s" reg)))))) + (t (compiler-bug "Unknown register class for reg ~s" reg)))))) ;;; The compiler often generates superfluous pushes & pops. Try to @@ -3086,5 +3086,5 @@ (let* ((root-var (nx-root-var var)) (other-guy - (dolist (v own-inhvars #|(error "other guy not found")|# root-var) + (dolist (v own-inhvars #|(compiler-bug "other guy not found")|# root-var) (when (eq root-var (nx-root-var v)) (return v))))) (push (make-acode (%nx1-operator inherited-arg) other-guy) inhforms))) @@ -3322,5 +3322,5 @@ (dest-crf (backend-ea-physical-reg dest hard-reg-class-crf))) (if (and dest-gpr (eql dest-gpr ppc::rzero)) - (break "Bad destination register: ~s" dest-gpr)) + (compiler-bug "Bad destination register: ~s" dest-gpr)) (if (null src) (if dest-gpr @@ -3788,5 +3788,5 @@ (progn (when (%ilogbitp $vbitpunted bits) - (error "bind-var: var ~s was punted" var)) + (compiler-bug "bind-var: var ~s was punted" var)) (when make-vcell (with-node-temps () (vcell closed) @@ -3820,5 +3820,5 @@ (not (logbitp $vbitpunted bits)))) (let ((endnote (%car (%cdddr (assq var *ppc2-recorded-symbols*))))) - (unless endnote (error "ppc2-close-var for ~s ?" (var-name var))) + (unless endnote (compiler-bug "ppc2-close-var for ~s ?" (var-name var))) (setf (vinsn-note-class endnote) :end-variable-scope) (append-dll-node (vinsn-note-label endnote) seg))))) @@ -5014,5 +5014,5 @@ (declare (fixnum numopt nkeys numreq vtotal doadlword)) (when (or (> numreq 255) (> numopt 255) (> nkeys 255)) - (error "A lambda list can contain a maximum of 255 required, 255 optional, and 255 keywords args")) + (compiler-bug "A lambda list can contain a maximum of 255 required, 255 optional, and 255 keywords args")) (if (fixnump listform) (ppc2-store-ea seg listform listreg) @@ -5106,5 +5106,5 @@ (cond ((typep valform 'keyword) (or (assq valform unique-labels) - (error "unknown vinsn label ~s" valform))) + (compiler-bug "unknown vinsn label ~s" valform))) ((atom valform) valform) ((atom (cdr valform)) (svref vp (car valform))) @@ -5143,10 +5143,10 @@ (unless (eval-predicate pred) (return nil)))) - (t (error "Unknown predicate: ~s" f)))) + (t (compiler-bug "Unknown predicate: ~s" f)))) (expand-form (f) (if (keywordp f) (emit-lap-label (assq f unique-labels)) (if (atom f) - (error "Invalid form in vinsn body: ~s" f) + (compiler-bug "Invalid form in vinsn body: ~s" f) (if (atom (car f)) (expand-insn-form f) @@ -5525,5 +5525,5 @@ (defppc2 ppc2-%primitive %primitive (seg vreg xfer &rest ignore) (declare (ignore seg vreg xfer ignore)) - (error "You're probably losing big: using %primitive ...")) + (compiler-bug "You're probably losing big: using %primitive ...")) (defppc2 ppc2-consp consp (seg vreg xfer cc form) @@ -5991,5 +5991,5 @@ (and nil (format t "~& could use cell ~s for var ~s" cell (var-name varnode))) (if (logbitp ppc2-debug-verbose-bit *ppc2-debug-mask*) - (break "wrong ea for lcell for var ~s: got ~d, expected ~d" + (compiler-bug "wrong ea for lcell for var ~s: got ~d, expected ~d" (var-name varnode) (calc-lcell-offset cell) (logand ea-or-form #xffff)))) (if (not cell) @@ -5999,5 +5999,5 @@ (unless (or (typep ea-or-form 'lreg) (fixnump ea-or-form)) - (break "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) + (compiler-bug "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) (ppc2-do-lexical-reference seg vreg ea-or-form) (^))))) @@ -6005,5 +6005,5 @@ (defppc2 ppc2-setq-lexical setq-lexical (seg vreg xfer varspec form) (let* ((ea (var-ea varspec))) - ;(unless (fixnump ea) (break "setq lexical is losing BIG")) + ;(unless (fixnump ea) (compiler-bug "setq lexical is losing BIG")) (let* ((valreg (ppc2-one-untargeted-reg-form seg form (if (and (register-spec-p ea) (or (null vreg) (eq ea vreg))) @@ -6025,5 +6025,5 @@ (if (= class hard-reg-class-crf) (progn - ;(break "Would have clobbered a GPR!") + ;(compiler-bug "Would have clobbered a GPR!") (ppc2-branch seg (ppc2-cd-true xfer) nil)) (progn @@ -7847,5 +7847,5 @@ (progn (unless (logbitp (hard-regspec-value vreg) ppc-imm-regs) - (error "I give up. When will I get this right ?")) + (compiler-bug "I give up. When will I get this right ?")) (let* ((natural-reg (ppc2-one-targeted-reg-form seg form Index: /branches/event-ide/ccl/compiler/X86/X8664/x8664-arch.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/X8664/x8664-arch.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/X8664/x8664-arch.lisp (revision 8262) @@ -213,6 +213,6 @@ (defx86reg save3 r11) (defx86reg save3.l r11d) -(defx86reg save3.w r10w) -(defx86reg save3.b r10b) +(defx86reg save3.w r11w) +(defx86reg save3.b r11b) (defx86reg save2 r12) @@ -546,4 +546,6 @@ writer ;tcr of owning thread or 0 name + whostate + whostate-2 ) @@ -611,4 +613,13 @@ xtra) +(define-storage-layout tsp-frame 0 + backptr + rbp) + +(define-storage-layout csp-frame 0 + backptr + rbp) + + (define-storage-layout xcf 0 ;"exception callback frame" backptr @@ -619,4 +630,7 @@ xp ra0 + foreign-sp ; value of tcr.foreign_sp + prev-xframe ; tcr.xframe before exception + ; (last 2 needed by apply-in-frame) ) @@ -724,4 +738,15 @@ malloced-ptr spinlock) + +(define-storage-layout rwlock 0 + spin + state + blocked-writers + blocked-readers + writer + reader-signal + writer-signal + malloced-ptr + ) (defmacro define-header (name element-count subtag) @@ -1228,11 +1253,11 @@ `(let* ((,typecode (ccl::typecode ,thing))) (declare (fixnum ,typecode)) - (and (<= ,typecode x8664::subtag-instance) - (logbitp (the (integer 0 #.x8664::subtag-instance) ,typecode) - (logior (ash 1 x8664::tag-fixnum) - (ash 1 x8664::tag-imm-0) - (ash 1 x8664::tag-imm-1) - (ash 1 x8664::fulltag-symbol) - (ash 1 x8664::subtag-instance))))))) + (or (= ,typecode x8664::subtag-instance) + (and (<= ,typecode x8664::fulltag-symbol) + (logbitp (the (integer 0 #.x8664::fulltag-symbol) ,typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-imm-0) + (ash 1 x8664::tag-imm-1) + (ash 1 x8664::fulltag-symbol)))))))) ;;; @@ -1303,4 +1328,9 @@ (defconstant recover-fn-from-rip-byte2 #x2d) +;;; For backtrace: the relative PC of an argument-check trap +;;; must be less than or equal to this value. (Because of +;;; the way that we do "anchored" UUOs, it should always be =.) + +(defconstant arg-check-trap-pc-limit 7) (provide "X8664-ARCH") Index: /branches/event-ide/ccl/compiler/X86/X8664/x8664-backend.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/X8664/x8664-backend.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/X8664/x8664-backend.lisp (revision 8262) @@ -489,5 +489,5 @@ (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset (incf memory-arg-offset (* 8 (ceiling bits 64))))))) - (dynamic-extent-names name)) + (dynamic-extent-names name)) (progn (rlets (list name (foreign-record-type-name argtype))) @@ -511,5 +511,6 @@ (:unsigned-byte '%get-unsigned-byte) (:address - ;(dynamic-extent-names name) + #+nil + (dynamic-extent-names name) '%get-ptr)) ,stack-ptr Index: /branches/event-ide/ccl/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/X8664/x8664-vinsns.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/X8664/x8664-vinsns.lisp (revision 8262) @@ -291,32 +291,68 @@ (define-x8664-vinsn set-nargs (() ((n :s16const))) - ((:pred = n 0) - (xorw (:%w x8664::nargs ) (:%w x8664::nargs ))) - ((:not (:pred = n 0)) - (movw (:$w (:apply ash n x8664::word-shift)) (:%w x8664::nargs )))) + + ((:pred < n 16) + (xorl (:%l x8664::nargs.l ) (:%l x8664::nargs.l )) + ((:pred > n 0) + (addl (:$b (:apply ash n x8664::word-shift)) (:%l x8664::nargs.l)))) + ((:pred >= n 16) + (movl (:$l (:apply ash n x8664::word-shift)) (:%l x8664::nargs.l )))) (define-x8664-vinsn check-exact-nargs (() ((n :u16const))) + :resume ((:pred = n 0) (testw (:%w x8664::nargs) (:%w x8664::nargs))) ((:not (:pred = n 0)) (cmpw (:$w (:apply ash n x8664::word-shift)) (:%w x8664::nargs))) - (jz.pt :ok) - (uuo-error-wrong-number-of-args) - :ok) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-wrong-number-of-args))) (define-x8664-vinsn check-min-nargs (() - ((n :u16const))) - (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift))) - (jae.pt :ok) - (uuo-error-too-few-args) - :ok) + ((min :u16const))) + :resume + ((:pred = min 1) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (je :toofew)) + ((:not (:pred = min 1)) + (rcmpw (:%w x8664::nargs) (:$w (:apply ash min x8664::word-shift))) + (jb :toofew)) + + (:anchored-uuo-section :resume) + :toofew + (:anchored-uuo (uuo-error-too-few-args))) (define-x8664-vinsn check-max-nargs (() ((n :u16const))) + :resume (rcmpw (:%w x8664::nargs) (:$w (:apply ash n x8664::word-shift))) - (jbe.pt :ok) - (uuo-error-too-many-args) - :ok) + (ja :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-too-many-args))) + + +(define-x8664-vinsn check-min-max-nargs (() + ((min :u16const) + (max :u16))) + :resume + ((:pred = min 1) + (testw (:%w x8664::nargs) (:%w x8664::nargs)) + (je :toofew)) + ((:not (:pred = min 1)) + (rcmpw (:%w x8664::nargs) (:$w (:apply ash min x8664::word-shift))) + (jb :toofew)) + (rcmpw (:%w x8664::nargs) (:$w (:apply ash max x8664::word-shift))) + (ja :toomany) + + (:anchored-uuo-section :resume) + :toofew + (:anchored-uuo (uuo-error-too-few-args)) + (:anchored-uuo-section :resume) + :toomany + (:anchored-uuo (uuo-error-too-many-args))) @@ -518,8 +554,17 @@ (cmpb (:$b x8664::fulltag-nil) (:%b arg0))) +(define-x8664-vinsn compare-to-t (() + ((arg0 t))) + (cmpq (:$l x8664::t-value) (:%q arg0))) (define-x8664-vinsn ref-constant (((dest :lisp)) ((lab :label))) (movq (:@ (:^ lab) (:%q x8664::fn)) (:%q dest))) + +(define-x8664-vinsn compare-constant-to-register (() + ((lab :label) + (reg :lisp))) + (cmpq (:@ (:^ lab) (:%q x8664::fn)) (:%q reg))) + (define-x8664-vinsn (vpush-constant :push :node :vsp) (() @@ -560,9 +605,11 @@ (define-x8664-vinsn trap-unless-bit (() ((value :lisp))) - + :resume (testq (:$l (lognot x8664::fixnumone)) (:%q value)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q value) (:$ub arch::error-object-not-bit)) - :ok + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q value) (:$ub arch::error-object-not-bit))) ) @@ -570,52 +617,73 @@ ((object :lisp)) ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-list) (:%b tag)) - (je.pt :ok) - (uuo-error-reg-not-list (:%q object)) - :ok) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-list) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-list (:%q object)))) + + (define-x8664-vinsn trap-unless-cons (() - ((object :lisp)) - ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::fulltagmask) (:%b tag)) - (cmpb (:$b x8664::fulltag-cons) (:%b tag)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::fulltag-cons)) - :ok) - + ((object :lisp)) + ((tag :u8))) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-cons) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::fulltag-cons)))) + + (define-x8664-vinsn trap-unless-uvector (() ((object :lisp)) ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) - (jz.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::tag-misc)) - :ok) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::tag-misc)))) (define-x8664-vinsn trap-unless-single-float (() ((object :lisp))) + :resume (cmpb (:$b x8664::tag-single-float) (:%b object)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::tag-single-float)) - :ok) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::tag-single-float)))) (define-x8664-vinsn trap-unless-character (() ((object :lisp))) + :resume (cmpb (:$b x8664::subtag-character) (:%b object)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-character)) - :ok) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-character)))) (define-x8664-vinsn trap-unless-fixnum (() ((object :lisp)) ()) + :resume (testb (:$b x8664::tagmask) (:%b object)) - (je.pt :ok) - (uuo-error-reg-not-fixnum (:%q object)) - :ok) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-fixnum (:%q object)))) (define-x8664-vinsn set-flags-from-lisptag (() @@ -628,42 +696,51 @@ (tagval :u16const)) ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b tag)) + ;; This needs to be a sign-extending mov, since the cmpl below + ;; will sign-extend the 8-bit constant operand. + (movsbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) :have-tag - (cmpb (:$b tagval) (:%b tag)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub tagval)) - :ok) + (cmpl (:$b tagval) (:%l tag)) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub tagval)))) (define-x8664-vinsn trap-unless-double-float (() ((object :lisp)) ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b tag)) + (movsbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) :have-tag - (cmpb (:$b x8664::subtag-double-float) (:%b tag)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-double-float)) - :ok) + (cmpl (:$b x8664::subtag-double-float) (:%l tag)) + (jne :bad) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-double-float)))) (define-x8664-vinsn trap-unless-macptr (() ((object :lisp)) ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :resume + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b tag)) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) :have-tag (cmpb (:$b x8664::subtag-macptr) (:%b tag)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-macptr)) - :ok) + (jne :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-macptr)))) @@ -672,11 +749,14 @@ (v :lisp)) ((temp :u64))) + :resume (movq (:@ x8664::misc-header-offset (:%q v)) (:%q temp)) - (xorb (:%b temp) (:%b temp)) - (shrq (:$ub (- x8664::num-subtag-bits x8664::fixnumshift)) (:%q temp)) + (shrq (:$ub x8664::num-subtag-bits) (:%q temp)) + (shlq (:$ub x8664::fixnumshift) (:%q temp)) (rcmpq (:%q idx) (:%q temp)) - (jb.pt :ok) - (uuo-error-vector-bounds (:%q idx) (:%q v)) - :ok) + (jge :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-vector-bounds (:%q idx) (:%q v)))) @@ -721,29 +801,43 @@ (define-x8664-vinsn extract-tag (((tag :u8)) ((object :lisp))) - (movzbl (:%b object) (:%l tag)) - (andb (:$b x8664::tagmask) (:%b tag))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag))) (define-x8664-vinsn extract-tag-fixnum (((tag :imm)) ((object :lisp))) - (leal (:@ (:%q object) 8) (:%l tag)) + ((:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object)) + (shll (:$ub x8664::fixnumshift) (:%l object))) + ((:not (:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object))) + (imull (:$b x8664::fixnumone) (:%l object) (:%l tag))) (andl (:$b (ash x8664::tagmask x8664::fixnumshift)) (:%l tag))) (define-x8664-vinsn extract-fulltag (((tag :u8)) ((object :lisp))) - (movzbl (:%b object) (:%l tag)) - (andb (:$b x8664::fulltagmask) (:%b tag))) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag))) (define-x8664-vinsn extract-fulltag-fixnum (((tag :imm)) ((object :lisp))) - (leal (:@ (:%q object) 8) (:%l tag)) + ((:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object)) + (shll (:$ub x8664::fixnumshift) (:%l object))) + ((:not (:pred = + (:apply %hard-regspec-value tag) + (:apply %hard-regspec-value object))) + (imull (:$b x8664::fixnumone) (:%l object) (:%l tag))) (andl (:$b (ash x8664::fulltagmask x8664::fixnumshift)) (:%l tag))) (define-x8664-vinsn extract-typecode (((tag :u32)) ((object :lisp))) - (movzbl (:%b object) (:%l tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b tag)) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) :have-tag) @@ -751,11 +845,11 @@ ((object :lisp)) ((temp :u32))) - (movzbl (:%b object) (:%l temp)) - (andb (:$b x8664::tagmask) (:%b temp)) - (cmpb (:$b x8664::tag-misc) (:%b temp)) + (movl (:%l object) (:%l temp)) + (andl (:$b x8664::tagmask) (:%l temp)) + (cmpl (:$b x8664::tag-misc) (:%l temp)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b temp)) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l temp)) :have-tag - (leal (:@ (:%q temp) 8) (:%l tag))) + (imulq (:$b x8664::fixnumone) (:%q temp) (:%q tag))) @@ -769,9 +863,9 @@ (define-x8664-vinsn cr-bit->boolean (((dest :lisp)) - ((crbit :u8const)) - ((temp :u32))) - (movl (:$l x8664::t-value) (:%l temp)) - (leaq (:@ (- x8664::t-offset) (:%q temp)) (:%q dest)) - (cmovccl (:$ub crbit) (:%l temp) (:%l dest))) + ((crbit :u8const))) + (movl (:$l x8664::nil-value) (:%l dest)) + (cmovccl (:$ub crbit) (:@ (+ x8664::t-offset x8664::symbol.vcell) (:%l dest)) (:%l dest))) + + @@ -823,11 +917,14 @@ (define-x8664-vinsn unbox-u8 (((dest :u8)) ((src :lisp))) + :resume (movq (:$l (lognot (ash #xff x8664::fixnumshift))) (:%q dest)) (andq (:% src) (:% dest)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-8)) - :ok + (jne :bad) (movq (:%q src) (:%q dest)) - (shrq (:$ub x8664::fixnumshift) (:%q dest))) + (shrq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-8)))) (define-x8664-vinsn %unbox-u8 (((dest :u8)) @@ -839,25 +936,29 @@ (define-x8664-vinsn unbox-s8 (((dest :s8)) ((src :lisp))) + :resume (movq (:%q src) (:%q dest)) (shlq (:$ub (- x8664::nbits-in-word (+ 8 x8664::fixnumshift))) (:%q dest)) (sarq (:$ub (- x8664::nbits-in-word (+ 8 x8664::fixnumshift))) (:%q dest)) (cmpq (:%q src) (:%q dest)) - (jne.pn :bad) + (jne :bad) (testb (:$b x8664::fixnummask) (:%b dest)) - (jne.pn :bad) + (jne :bad) (sarq (:$ub x8664::fixnumshift) (:%q dest)) - (jmp :got-it) - :bad - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-8)) - :got-it) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-8)))) (define-x8664-vinsn unbox-u16 (((dest :u16)) ((src :lisp))) + :resume (testq (:$l (lognot (ash #xffff x8664::fixnumshift))) (:% src)) (movq (:%q src) (:%q dest)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-16)) - :ok - (shrq (:$ub x8664::fixnumshift) (:%q dest))) + (jne :bad) + (shrq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-16)))) (define-x8664-vinsn %unbox-u16 (((dest :u16)) @@ -868,15 +969,17 @@ (define-x8664-vinsn unbox-s16 (((dest :s16)) ((src :lisp))) + :resume (movq (:%q src) (:%q dest)) (shlq (:$ub (- x8664::nbits-in-word (+ 16 x8664::fixnumshift))) (:%q dest)) (sarq (:$ub (- x8664::nbits-in-word (+ 16 x8664::fixnumshift))) (:%q dest)) (cmpq (:%q src) (:%q dest)) - (jne.pn :bad) + (jne :bad) (testb (:$b x8664::fixnummask) (:%b dest)) - (je.pt :got-it) - :bad - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-16)) - :got-it - (sarq (:$ub x8664::fixnumshift) (:%q dest))) + (jne :bad) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-16)))) (define-x8664-vinsn %unbox-s16 (((dest :s16)) @@ -887,31 +990,36 @@ (define-x8664-vinsn unbox-u32 (((dest :u32)) ((src :lisp))) + :resume (movq (:$q (lognot (ash #xffffffff x8664::fixnumshift))) (:%q dest)) (testq (:% src) (:% dest)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-32)) - :ok + (jne :bad) + (movq (:%q src) (:%q dest)) + (shrq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-32)))) + +(define-x8664-vinsn %unbox-u32 (((dest :u32)) + ((src :lisp))) + (movq (:%q src) (:%q dest)) (shrq (:$ub x8664::fixnumshift) (:%q dest))) -(define-x8664-vinsn %unbox-u32 (((dest :u32)) - ((src :lisp))) - - (movq (:%q src) (:%q dest)) - (shrq (:$ub x8664::fixnumshift) (:%q dest))) - (define-x8664-vinsn unbox-s32 (((dest :s32)) ((src :lisp))) + :resume (movq (:%q src) (:%q dest)) (shlq (:$ub (- x8664::nbits-in-word (+ 32 x8664::fixnumshift))) (:%q dest)) (sarq (:$ub (- x8664::nbits-in-word (+ 32 x8664::fixnumshift))) (:%q dest)) (cmpq (:%q src) (:%q dest)) - (jne.pn :bad) + (jne :bad) (testb (:$b x8664::fixnummask) (:%b dest)) - (je.pt :got-it) - :bad - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-32)) - :got-it - (sarq (:$ub x8664::fixnumshift) (:%q dest))) + (jne :bad) + (sarq (:$ub x8664::fixnumshift) (:%q dest)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-32)))) (define-x8664-vinsn %unbox-s32 (((dest :s32)) @@ -923,4 +1031,5 @@ (define-x8664-vinsn unbox-u64 (((dest :u64)) ((src :lisp))) + :resume (movq (:$q (lognot (ash x8664::target-most-positive-fixnum x8664::fixnumshift))) (:%q dest)) (testq (:%q dest) (:%q src)) @@ -930,10 +1039,10 @@ (jmp :done) :maybe-bignum - (andb (:$b x8664::tagmask) (:%b dest)) - (cmpb (:$b x8664::tag-misc) (:%b dest)) + (andl (:$b x8664::tagmask) (:%l dest)) + (cmpl (:$b x8664::tag-misc) (:%l dest)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q src)) (:%b dest)) + (movzbl (:@ x8664::misc-subtag-offset (:%q src)) (:%l dest)) :have-tag - (cmpb (:$b x8664::subtag-bignum) (:%b dest)) + (cmpl (:$b x8664::subtag-bignum) (:%l dest)) (jne :bad) (movq (:@ x8664::misc-header-offset (:%q src)) (:%q dest)) @@ -944,7 +1053,7 @@ (movq (:@ x8664::misc-data-offset (:%q src)) (:%q dest)) (testq (:%q dest) (:%q dest)) - (jns :done) - :bad - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-64)) + (js :bad) + (jmp :done) + :three (movl (:@ (+ 8 x8664::misc-data-offset) (:%q src)) (:%l dest)) @@ -952,8 +1061,13 @@ (movq (:@ x8664::misc-data-offset (:%q src)) (:%q dest)) (jne :bad) - :done) + :done + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-unsigned-byte-64)))) (define-x8664-vinsn unbox-s64 (((dest :s64)) ((src :lisp))) + :resume (movq (:%q src) (:%q dest)) (sarq (:$ub x8664::fixnumshift) (:%q dest)) @@ -962,14 +1076,16 @@ (je :done) ;; May be a 2-digit bignum - (movb (:%b src) (:%b dest)) - (andb (:$b x8664::tagmask) (:%b dest)) - (cmpb (:$b x8664::tag-misc) (:%b dest)) + (movl (:%l src) (:%l dest)) + (andl (:$b x8664::tagmask) (:%l dest)) + (cmpl (:$b x8664::tag-misc) (:%l dest)) (jne :bad) (cmpq (:$l x8664::two-digit-bignum-header) (:@ x8664::misc-header-offset (:%q src))) (movq (:@ x8664::misc-data-offset (:%q src)) (:%q dest)) - (je :done) - :bad - (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-64)) - :done) + (jne :bad) + :done + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q src) (:$ub arch::error-object-not-signed-byte-64)))) (define-x8664-vinsn sign-extend-s8 (((dest :s64)) @@ -1164,9 +1280,15 @@ (header (:u64 #.x8664::imm0)) (entry (:label 1)))) - (jno.pt :done) + (jo :overflow) + :done + (:uuo-section) ((:not (:pred = x8664::arg_z (:apply %hard-regspec-value val))) + :overflow (movq (:%q val) (:%q x8664::arg_z))) (:talign 4) + ((:pred = x8664::arg_z + (:apply %hard-regspec-value val)) + :overflow) (call (:@ .SPfix-overflow)) (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) @@ -1174,5 +1296,5 @@ (:apply %hard-regspec-value val))) (movq (:%q x8664::arg_z) (:%q val))) - :done) + (jmp :done)) (define-x8664-vinsn (fix-fixnum-overflow-ool-and-branch :call) @@ -1183,9 +1305,15 @@ (header (:u64 #.x8664::imm0)) (entry (:label 1)))) - (jno.pt lab) + (jo :overflow) + (jmp lab) + (:uuo-section) ((:not (:pred = x8664::arg_z (:apply %hard-regspec-value val))) + :overflow (movq (:%q val) (:%q x8664::arg_z))) (:talign 4) + ((:pred = x8664::arg_z + (:apply %hard-regspec-value val)) + :overflow) (call (:@ .SPfix-overflow)) (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) @@ -1470,15 +1598,18 @@ ((source :lisp)) ((tag :u8))) - (movb (:%b source) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :resume + (movl (:%l source) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q source)) (:%b tag)) + (movsbl (:@ x8664::misc-subtag-offset (:%q source)) (:%l tag)) :have-tag - (cmpb (:$b x8664::subtag-double-float) (:%b tag)) - (je.pt :ok) - (uuo-error-reg-not-tag (:%q source) (:$ub x8664::subtag-double-float)) - :ok - (movsd (:@ x8664::double-float.value (:%q source)) (:%xmm target))) + (cmpl (:$b x8664::subtag-double-float) (:%l tag)) + (jne :bad) + (movsd (:@ x8664::double-float.value (:%q source)) (:%xmm target)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q source) (:$ub x8664::subtag-double-float)))) (define-x8664-vinsn single->node (((result :lisp) @@ -1574,7 +1705,8 @@ () ((tag :u8))) - (movb (:%b x8664::temp0) (:%b tag)) - (andb (:$b x8664::fulltagmask) (:%b tag)) - (cmpb (:$b x8664::fulltag-symbol) (:%b tag)) + :resume + (movl (:%l x8664::temp0) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-symbol) (:%l tag)) (cmovgq (:%q x8664::temp0) (:%q x8664::fn)) (jl :bad) @@ -1582,10 +1714,8 @@ (pushq (:@ (+ x8664::nil-value (x8664::%kernel-global 'x86::ret1valaddr)))) (jmp (:%q x8664::fn)) - :bad - (uuo-error-not-callable) - ;; If we don't do this (and leave %fn as a TRA into itself), reporting - ;; the error is likely a little harder. Tough. - ;; (leaq (@ (:apply - (:^ :bad)) (:%q x8664::rn)) (:%q x8664::fn)) -) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) @@ -1629,4 +1759,5 @@ (movq (:@ (:%seg :rcontext) x8664::tcr.save-tsp) (:%mmx x8664::stack-temp)) (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) (leaq (:@ (+ x8664::dnode-size x8664::fulltag-cons) (:%q temp)) (:%q temp)) @@ -1657,4 +1788,5 @@ (jnz :loop) (movq (:%mmx x8664::stack-temp) (:@ (:%q tempa))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q tempa))) (movq (:%q tempa) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) (movl (:$l header) (:@ x8664::dnode-size (:%q tempa))) @@ -1704,5 +1836,5 @@ (defmacro define-x8664-subprim-jump-vinsn ((name &rest other-attrs) spno) - `(define-x8664-vinsn (,name :jump :jumpLR ,@other-attrs) (() ()) + `(define-x8664-vinsn (,name :jumpLR ,@other-attrs) (() ()) (jmp (:@ ,spno)))) @@ -1836,28 +1968,33 @@ ((tag :u8) (entry (:label 1)))) - (movb (:%b x8664::temp0) (:%b tag)) - (andb (:$b x8664::fulltagmask) (:%b tag)) - (cmpb (:$b x8664::fulltag-symbol) (:%b tag)) + :resume + (movl (:%l x8664::temp0) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-symbol) (:%l tag)) (cmovgq (:%q x8664::temp0) (:%q x8664::xfn)) - (jge.pt :call) - (uuo-error-not-callable) - :call + (jl :bad) (cmoveq (:@ x8664::symbol.fcell (:%q x8664::fname)) (:%q x8664::xfn)) (:talign 4) (call (:%q x8664::xfn)) - (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) (define-x8664-vinsn tail-funcall (() () - ((tag :u8))) - (movb (:%b x8664::temp0) (:%b tag)) - (andb (:$b x8664::fulltagmask) (:%b tag)) - (cmpb (:$b x8664::fulltag-symbol) (:%b tag)) + ((tag (:u8 #.x8664::imm0)))) + :resume + (movl (:%l x8664::temp0) (:%l tag)) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-symbol) (:%l tag)) (cmovgq (:%q x8664::temp0) (:%q x8664::xfn)) (jl :bad) (cmoveq (:@ x8664::symbol.fcell (:%q x8664::fname)) (:%q x8664::xfn)) (jmp (:%q x8664::xfn)) - :bad - (uuo-error-not-callable)) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-not-callable))) @@ -1892,4 +2029,5 @@ ((table :imm) (idx :imm))) + :resume (movq (:@ x8664::symbol.binding-index (:%q src)) (:%q idx)) (rcmpq (:%q idx) (:@ (:%seg :rcontext) x8664::tcr.tlb-limit)) @@ -1897,13 +2035,15 @@ (jae :symbol) (movq (:@ (:%q table) (:%q idx)) (:%q dest)) - (cmpb (:$b x8664::subtag-no-thread-local-binding) (:%b dest)) + (cmpl (:$b x8664::subtag-no-thread-local-binding) (:%l dest)) (jne :test) :symbol (movq (:@ x8664::symbol.vcell (:%q src)) (:%q dest)) :test - (cmpb (:$b x8664::unbound-marker) (:%b dest)) - (jne.pt :done) - (uuo-error-unbound (:%q src)) - :done) + (cmpl (:$b x8664::unbound-marker) (:%l dest)) + (je :bad) + + (:anchored-uuo-section :resume) + :bad + (:anchored-uuo (uuo-error-unbound (:%q src)))) @@ -1991,8 +2131,9 @@ ((w :u64))) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) - (subq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) - (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) + (subq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) - (movq (:%q w) (:@ 8 (:%q x8664::ra0)))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))) + (movq (:%q w) (:@ x8664::dnode-size (:%q x8664::ra0)))) @@ -2007,4 +2148,5 @@ (movapd (:%xmm x8664::fpzero) (:@ 16 (:%q temp))) (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) (movq (:%q w) (:@ x8664::dnode-size (:%q temp)))) @@ -2014,8 +2156,9 @@ ((f :double-float))) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) - (subq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (subq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) - (movsd (:%xmm f) (:@ 8 (:%q x8664::ra0)))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))) + (movapd (:%xmm f) (:@ x8664::dnode-size (:%q x8664::ra0)))) @@ -2036,6 +2179,6 @@ ()) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) - (movq (:@ 8 (:%q x8664::ra0)) (:%q w)) - (addq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) + (movq (:@ x8664::dnode-size (:%q x8664::ra0)) (:%q w)) + (addq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) @@ -2054,6 +2197,6 @@ ()) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) - (movsd (:@ 8 (:%q x8664::ra0)) (:%xmm f)) - (addq (:$b 16) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) + (movapd (:@ x8664::dnode-size (:%q x8664::ra0)) (:%xmm f)) + (addq (:$b (* 2 x8664::dnode-size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) @@ -2062,8 +2205,9 @@ ((ptr :address))) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%mmx x8664::stack-temp)) - (subq (:$b (+ 16 x8664::macptr.size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) + (subq (:$b (+ x8664::dnode-size x8664::macptr.size)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) - (leaq (:@ (+ 16 x8664::fulltag-misc) (:%q x8664::ra0)) (:%q dest)) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0))) + (leaq (:@ (+ x8664::dnode-size x8664::fulltag-misc) (:%q x8664::ra0)) (:%q dest)) (movq (:$l x8664::macptr-header) (:@ x8664::macptr.header (:%q dest))) (movq (:%q ptr) (:@ x8664::macptr.address (:%q dest))) @@ -2594,9 +2738,9 @@ ((object :lisp))) :again - (testb (:$b x8664::fixnummask) (:%b object)) - (je.pt :got-it) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-fixnum)) - (jmp :again) - :got-it) + (testl (:$l x8664::fixnummask) (:%l object)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-fixnum)))) (define-x8664-vinsn require-integer (() @@ -2604,15 +2748,16 @@ ((tag :u8))) :again - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::fixnummask) (:%b tag)) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fixnummask) (:%l tag)) (je.pt :got-it) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :bad) (cmpb (:$b x8664::subtag-bignum) (:@ x8664::misc-subtag-offset (:%q object))) - (je :got-it) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-integer)) - (jmp :again) - :got-it) + (jne :bad) + :got-it + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-integer)))) (define-x8664-vinsn require-simple-vector (() @@ -2620,14 +2765,14 @@ ((tag :u8))) :again - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::fixnummask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fixnummask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :bad) (cmpb (:$b x8664::subtag-simple-vector) (:@ x8664::misc-subtag-offset (:%q object))) - (je :got-it) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-simple-vector)) - (jmp :again) - :got-it) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-simple-vector)))) (define-x8664-vinsn require-simple-string (() @@ -2635,14 +2780,14 @@ ((tag :u8))) :again - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::fixnummask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::fixnummask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :bad) (cmpb (:$b x8664::subtag-simple-base-string) (:@ x8664::misc-subtag-offset (:%q object))) - (je :got-it) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-simple-string)) - (jmp :again) - :got-it) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-simple-string)))) (define-x8664-vinsn require-real (() @@ -2657,18 +2802,18 @@ (:%q mask)) :again - (movb (:$b x8664::tagmask) (:%b tag)) - (andb (:%b object) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b tag)) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) :have-tag - (rcmpb (:%b tag) (:$b 64)) + (rcmpl (:%l tag) (:$b 64)) (jae :bad) (btq (:%q tag) (:%q mask)) - (jb.pt :good) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-real)) - (jmp :again) - :good) + (jae :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-real)))) (define-x8664-vinsn require-number (() @@ -2684,19 +2829,17 @@ (:%q mask)) :again - (movb (:$b x8664::tagmask) (:%b tag)) - (andb (:%b object) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q object)) (:%b tag)) + (movzbl (:@ x8664::misc-subtag-offset (:%q object)) (:%l tag)) :have-tag - (rcmpb (:%b tag) (:$b 64)) - ;;(movzbl (:%b tag) (:%l tag)) + (rcmpl (:%l tag) (:$b 64)) (jae :bad) (btq (:%q tag) (:%q mask)) - (jb.pt :good) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-number)) - (jmp :again) - :good) + (jae :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-number)))) (define-x8664-vinsn require-list (() @@ -2704,11 +2847,12 @@ ((tag :u8))) :again - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-list) (:%b tag)) - (je :good) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-list)) - (jmp :again) - :good) + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-list) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-list)))) (define-x8664-vinsn require-symbol (() @@ -2716,13 +2860,15 @@ ((tag :u8))) :again - (cmpb (:$b x8664::fulltag-nil) (:%b object)) + (movzbl (:%b object) (:%l tag)) + (cmpl (:$b x8664::fulltag-nil) (:%l tag)) (je :good) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-symbol) (:%b tag)) - (je :good) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-symbol)) - (jmp :again) - :good) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-symbol) (:%l tag)) + (jne :bad) + :good + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-symbol)))) (define-x8664-vinsn require-character (() @@ -2730,8 +2876,8 @@ :again (cmpb (:$b x8664::subtag-character) (:%b object)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-character)) - (jmp :again) - :ok) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-character)))) (define-x8664-vinsn require-s8 (() @@ -2744,9 +2890,9 @@ (shlq (:$ub x8664::fixnumshift) (:%q tag)) (cmpq (:%q object) (:%q tag)) - (je.pt :ok) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-8)) - (jmp :again) - :ok) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-8)))) (define-x8664-vinsn require-u8 (() @@ -2756,8 +2902,8 @@ (movq (:$l (lognot (ash #xff x8664::fixnumshift))) (:%q tag)) (andq (:% object) (:% tag)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-8)) - (jmp :again) - :ok) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-8)))) (define-x8664-vinsn require-s16 (() @@ -2770,9 +2916,8 @@ (shlq (:$ub x8664::fixnumshift) (:%q tag)) (cmpq (:%q object) (:%q tag)) - (je.pt :ok) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-16)) - (jmp :again) - :ok) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-16)))) (define-x8664-vinsn require-u16 (() @@ -2782,8 +2927,8 @@ (movq (:$l (lognot (ash #xffff x8664::fixnumshift))) (:%q tag)) (andq (:% object) (:% tag)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-16)) - (jmp :again) - :ok) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-16)))) (define-x8664-vinsn require-s32 (() @@ -2796,11 +2941,10 @@ (shlq (:$ub x8664::fixnumshift) (:%q tag)) (cmpq (:%q object) (:%q tag)) - (jne.pn :bad) - (testb (:$b x8664::fixnummask) (:%b object)) - (je.pt :bad) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-32)) - (jmp :again) - :ok) + (jne :bad) + (testl (:$l x8664::fixnummask) (:%l object)) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-32)))) (define-x8664-vinsn require-u32 (() @@ -2810,8 +2954,8 @@ (movq (:$q (lognot (ash #xffffffff x8664::fixnumshift))) (:%q tag)) (andq (:% object) (:% tag)) - (je.pt :ok) - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-32)) - (jmp :again) - :ok) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-32)))) (define-x8664-vinsn require-s64 (() @@ -2819,16 +2963,16 @@ ((tag :s64))) :again - (testb (:$b x8664::fixnummask) (:%b object)) - (movq (:%q object) (:%q tag)) + (testl (:$l x8664::fixnummask) (:%l object)) + (movl (:%l object) (:%l tag)) (je.pt :ok) - (andb (:$b x8664::fulltagmask) (:%b tag)) - (cmpb (:$b x8664::fulltag-misc) (:%b tag)) - (jne.pn :bad) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-misc) (:%l tag)) + (jne :bad) (cmpq (:$l x8664::two-digit-bignum-header) (:@ x8664::misc-header-offset (:%q object))) - (je.pt :ok) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-64)) - (jmp :again) - :ok) + (jne :bad) + :ok + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-signed-byte-64)))) (define-x8664-vinsn require-u64 (() @@ -2836,10 +2980,10 @@ ((tag :s64))) :again - (testb (:$b x8664::fixnummask) (:%b object)) + (testl (:$l x8664::fixnummask) (:%l object)) (movq (:%q object) (:%q tag)) (je.pt :ok-if-non-negative) - (andb (:$b x8664::fulltagmask) (:%b tag)) - (cmpb (:$b x8664::fulltag-misc) (:%b tag)) - (jne.pn :bad) + (andl (:$b x8664::fulltagmask) (:%l tag)) + (cmpl (:$b x8664::fulltag-misc) (:%l tag)) + (jne :bad) (cmpq (:$l x8664::two-digit-bignum-header) (:@ x8664::misc-header-offset (:%q object))) (je :two) @@ -2848,7 +2992,5 @@ (cmpl (:$b 0) (:@ (+ x8664::misc-data-offset 8) (:%q object))) (je :ok) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-64)) - (jmp :again) + (jmp :bad) :two (movq (:@ x8664::misc-data-offset (:%q object)) (:%q tag)) @@ -2856,5 +2998,8 @@ (testq (:%q tag) (:%q tag)) (js :bad) - :ok) + :ok + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-unsigned-byte-64)))) (define-x8664-vinsn require-char-code (() @@ -2862,17 +3007,14 @@ ((tag :u32))) :again - (testb (:$b x8664::fixnummask) (:%b object)) - (jne.pn :bad) + (testl (:$l x8664::fixnummask) (:%l object)) + (jne :bad) (cmpq (:$l (ash #x110000 x8664::fixnumshift)) (:%q object)) - (jb.pt :ok) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-mod-char-code-limit)) - (jmp :again) - :ok) - - - - - + (jae :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub arch::error-object-not-mod-char-code-limit)))) + + +;;; set DEST to (define-x8664-vinsn mask-base-char (((dest :u8)) ((src :lisp))) @@ -2902,7 +3044,6 @@ ((temp :u64))) (movq (:@ x8664::misc-header-offset (:%q src)) (:%q temp)) - (movb (:$b 0) (:%b temp)) - (movq (:%q temp) (:%q dest)) - (shrq (:$ub (- x8664::num-subtag-bits x8664::fixnumshift)) (:%q dest))) + (shrq (:$ub x8664::num-subtag-bits) (:%q temp)) + (imulq (:$b x8664::fixnumone) (:%q temp)(:%q dest))) (define-x8664-vinsn %logior2 (((dest :imm)) @@ -3208,11 +3349,11 @@ (valtype :lisp))) (xorl (:%l valtype) (:%l valtype)) - (movb (:%b val) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + (movl (:%l val) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :have-tag) - (movb (:@ x8664::misc-subtag-offset (:%q val)) (:%b tag)) + (movzbl (:@ x8664::misc-subtag-offset (:%q val)) (:%l tag)) :have-tag - (cmpb (:$b x8664::subtag-istruct) (:%b tag)) + (cmpl (:$b x8664::subtag-istruct) (:%l tag)) (jne :do-compare) (movq (:@ x8664::misc-data-offset (:%q val)) (:%q valtype)) @@ -3291,30 +3432,36 @@ ((src :lisp)) ((tag :u8))) + :begin (movl (:$l (+ x8664::nil-value x8664::nilsym-offset)) (:%l tag)) (cmpb (:$b x8664::fulltag-nil) (:%b src)) (cmoveq (:%q tag) (:%q dest)) - (movb (:%b src) (:%b tag)) + (movl (:%l src) (:%l tag)) (je :ok) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-symbol) (:%b tag)) - (je.pt :no-trap) - (uuo-error-reg-not-tag (:%q src) (:$ub x8664::fulltag-symbol)) - :no-trap + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-symbol) (:%l tag)) + (jne :bad) + ((:not (:pred = (:apply %hard-regspec-value dest) (:apply %hard-regspec-value src))) (movq (:% src) (:% dest))) - :ok) + :ok + (:anchored-uuo-section :begin) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q src) (:$ub x8664::fulltag-symbol)))) (define-x8664-vinsn symbol-function (((val :lisp)) ((sym (:lisp (:ne val)))) ((tag :u8))) + :anchor (movq (:@ x8664::symbol.fcell (:%q sym)) (:%q val)) - (movb (:%b val) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-function) (:%b tag)) - (je.pt :ok) - (uuo-error-udf (:%q sym)) - :ok) + (movl (:%l val) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-function) (:%l tag)) + (jne :bad) + + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-udf (:%q sym)))) (define-x8664-subprim-jump-vinsn (tail-call-fn-slide) .SPtcallnfnslide) @@ -3340,12 +3487,13 @@ ;;; really known, it should probably be inlined (stack-cleanup, value ;;; transfer & jump ...) -(define-x8664-vinsn (throw :jump :jump-unknown) (() - () - ((entry (:label 1)))) +(define-x8664-vinsn (throw :jump-unknown) (() + () + ((entry (:label 1)))) (leaq (:@ (:^ :back) (:%q x8664::fn)) (:%q x8664::ra0)) (:talign 4) (jmp (:@ .SPthrow)) :back - (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) + (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)) + (uuo-error-reg-not-tag (:%q x8664::temp0) (:$ub x8664::subtag-catch-frame))) @@ -3353,10 +3501,12 @@ (define-x8664-vinsn unbox-base-char (((dest :u64)) ((src :lisp))) + :anchor (movq (:%q src) (:%q dest)) (shrq (:$ub x8664::charcode-shift) (:%q dest)) (cmpb (:$b x8664::subtag-character) (:%b src)) - (je.pt ::got-it) - (uuo-error-reg-not-tag (:%q src) (:$ub x8664::subtag-character)) - :got-it) + (jne :bad) + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-reg-not-tag (:%q src) (:$ub x8664::subtag-character)))) (define-x8664-subprim-lea-jmp-vinsn (save-values) .SPsave-values) @@ -3468,5 +3618,6 @@ (subq (:$l (:apply ash (:apply logandc2 (:apply + nwords 9) 1) x8664::word-shift)) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp))) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) - (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))) (define-x8664-vinsn alloc-variable-c-frame (() @@ -3479,5 +3630,6 @@ (subq (:%q size) (:@ (:%seg :rcontext) x8664::tcr.foreign-sp)) (movq (:@ (:%seg :rcontext) x8664::tcr.foreign-sp) (:%q x8664::ra0)) - (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0)))) + (movq (:%mmx x8664::stack-temp) (:@ (:%q x8664::ra0))) + (movq (:% x8664::rbp) (:@ x8664::csp-frame.rbp (:%q x8664::ra0)))) (define-x8664-vinsn set-c-arg (() @@ -3540,5 +3692,6 @@ (movapd (:%xmm x8664::fpzero) (:@ (:%q temp))) (movapd (:%xmm x8664::fpzero) (:@ x8664::dnode-size (:%q temp))) - (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:%mmx x8664::stack-temp) (:@ (:%q temp))) + (movq (:% x8664::rbp) (:@ x8664::tsp-frame.rbp (:%q temp))) (movq (:%q temp) (:@ (:%seg :rcontext) x8664::tcr.save-tsp)) (movq (:$l x8664::value-cell-header) (:@ x8664::dnode-size (:%q temp))) @@ -3585,8 +3738,10 @@ (index :lisp))) (movq (:@ x8664::misc-data-offset (:%q instance) (:%q index)) (:%q dest)) - (cmpb (:$b x8664::slot-unbound-marker) (:%b dest)) - (jne.pt :ok) - (uuo-error-slot-unbound (:%q dest) (:%q instance) (:%q index)) - :ok) + (cmpl (:$b x8664::slot-unbound-marker) (:%l dest)) + (je :bad) + :ok + (:anchored-uuo-section :ok) + :bad + (:anchored-uuo (uuo-error-slot-unbound (:%q dest) (:%q instance) (:%q index)))) (define-x8664-vinsn eep.address (((dest t)) @@ -3595,7 +3750,10 @@ (:%q dest)) (cmpb (:$b x8664::fulltag-nil) (:%b dest)) - (jne :ok) - (uuo-error-eep-unresolved (:%q src) (:%q dest)) - :ok) + (je :bad) + :ok + (:anchored-uuo-section :ok) + :bad + (:anchored-uuo (uuo-error-eep-unresolved (:%q src) (:%q dest)))) + (define-x8664-subprim-lea-jmp-vinsn (heap-cons-rest-arg) .SPheap-cons-rest-arg) @@ -3855,6 +4013,6 @@ (define-x8664-vinsn %natural- (((result :u64)) - ((result :u64) - (other :u64))) + ((result :u64) + (other :u64))) (subq (:%q other) (:%q result))) @@ -3909,8 +4067,8 @@ (type-error :u8const)) ((tag :u8))) - - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :bad) (cmpb (:$b x8664::subtag-arrayH) (:@ x8664::misc-subtag-offset (:%q object))) @@ -3919,8 +4077,9 @@ (jne :bad) (cmpq (:$l (:apply ash expected-flags x8664::fixnumshift)) (:@ x8664::arrayH.flags (:%q object))) - (je.pt :good) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub type-error)) - :good) + (jne :bad) + + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub type-error)))) (define-x8664-vinsn trap-unless-simple-array-3 (() @@ -3929,8 +4088,8 @@ (type-error :u8const)) ((tag :u8))) - - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :bad) (cmpb (:$b x8664::subtag-arrayH) (:@ x8664::misc-subtag-offset (:%q object))) @@ -3939,21 +4098,23 @@ (jne :bad) (cmpq (:$l (:apply ash expected-flags x8664::fixnumshift)) (:@ x8664::arrayH.flags (:%q object))) - (je.pt :good) - :bad - (uuo-error-reg-not-type (:%q object) (:$ub type-error)) - :good) + (jne :bad) + (:anchored-uuo-section :again) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q object) (:$ub type-error)))) (define-x8664-vinsn trap-unless-array-header (() ((object :lisp)) ((tag :u8))) - (movb (:%b object) (:%b tag)) - (andb (:$b x8664::tagmask) (:%b tag)) - (cmpb (:$b x8664::tag-misc) (:%b tag)) + :again + (movl (:%l object) (:%l tag)) + (andl (:$b x8664::tagmask) (:%l tag)) + (cmpl (:$b x8664::tag-misc) (:%l tag)) (jne :trap) (cmpb (:$b x8664::subtag-arrayH) (:@ x8664::misc-subtag-offset (:%q object))) - (je :ok) + (jne :trap) + + (:anchored-uuo-section :again) :trap - (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-arrayH)) - :ok) + (:anchored-uuo (uuo-error-reg-not-tag (:%q object) (:$ub x8664::subtag-arrayH)))) (define-x8664-vinsn check-arrayH-rank (() @@ -3961,9 +4122,11 @@ (expected :u32const)) ((rank :imm))) + :anchor (movl (:$l (:apply ash expected x8664::fixnumshift)) (:%l rank)) (cmpq (:@ x8664::arrayH.rank (:%q header)) (:%q rank)) - (je.pt :ok) - (uuo-error-array-rank (:%q header) (:%q rank)) - :ok) + (jne :bad) + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-array-rank (:%q header) (:%q rank)))) (define-x8664-vinsn check-arrayH-flags (() @@ -3971,9 +4134,11 @@ (expected :u32const) (type-error :u8const))) + :anchor (cmpq (:$l (:apply ash expected x8664::fixnumshift)) (:@ x8664::arrayH.flags (:%q header))) - (je.pt :ok) - (uuo-error-reg-not-type (:%q header) (:$ub type-error)) - :ok) + (jne :bad) + (:anchored-uuo-section :anchor) + :bad + (:anchored-uuo (uuo-error-reg-not-type (:%q header) (:$ub type-error)))) (define-x8664-vinsn misc-ref-c-u16 (((dest :u16)) @@ -4127,15 +4292,18 @@ (j :imm) (header :lisp))) + :anchor (cmpq (:@ (+ x8664::misc-data-offset (* 8 x8664::arrayH.dim0-cell)) (:%q header)) (:%q i)) - (jb :i-ok) - (uuo-error-array-bounds (:%q i) (:%q header)) - :i-ok + (jae :bad-i) (movq (:@ (+ x8664::misc-data-offset (* 8 (1+ x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim)) (cmpq (:%q dim) (:%q j)) - (jb :j-ok) - (uuo-error-array-bounds (:%q j) (:%q header)) - :j-ok - (sarq (:$ub x8664::fixnumshift) (:%q dim))) + (jae :bad-j) + (sarq (:$ub x8664::fixnumshift) (:%q dim)) + (:anchored-uuo-section :anchor) + :bad-i + (:anchored-uuo (uuo-error-array-bounds (:%q i) (:%q header))) + (:anchored-uuo-section :anchor) + :bad-j + (:anchored-uuo (uuo-error-array-bounds (:%q j) (:%q header)))) ;;; Return dim1, dim2 (unboxed) @@ -4146,20 +4314,25 @@ (k :imm) (header :lisp))) + :anchor (cmpq (:@ (+ x8664::misc-data-offset (* 8 x8664::arrayH.dim0-cell)) (:%q header)) (:%q i)) - (jb :i-ok) - (uuo-error-array-bounds (:%q i) (:%q header)) - :i-ok + (jae :bad-i) (movq (:@ (+ x8664::misc-data-offset (* 8 (1+ x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim1)) (cmpq (:%q dim1) (:%q j)) - (jb :j-ok) - (uuo-error-array-bounds (:%q j) (:%q header)) - :j-ok + (jae :bad-j) (sarq (:$ub x8664::fixnumshift) (:%q dim1)) (movq (:@ (+ x8664::misc-data-offset (* 8 (+ 2 x8664::arrayH.dim0-cell))) (:%q header)) (:%q dim2)) (cmpq (:%q dim2) (:%q k)) - (jb ::k-ok) - (uuo-error-array-bounds (:%q k) (:%q header)) - :k-ok - (sarq (:$ub x8664::fixnumshift) (:%q dim2))) + (jae :bad-k) + (sarq (:$ub x8664::fixnumshift) (:%q dim2)) + (:anchored-uuo-section :anchor) + :bad-i + (:anchored-uuo (uuo-error-array-bounds (:%q i) (:%q header))) + (:anchored-uuo-section :anchor) + :bad-j + (:anchored-uuo (uuo-error-array-bounds (:%q j) (:%q header))) + (:anchored-uuo-section :anchor) + :bad-k + (:anchored-uuo (uuo-error-array-bounds (:%q k) (:%q header))) + ) @@ -4209,6 +4382,6 @@ (dest :label)) ((tag :u8))) - (movb (:%b a) (:%b tag)) - (orb (:%b b) (:%b tag)) + (movl (:%l a) (:%l tag)) + (orl (:%l b) (:%l tag)) (testb (:$b x8664::fixnummask) (:%b tag)) (jne dest)) @@ -4244,5 +4417,10 @@ ((entry (:label 1)))) (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn))) - + +(define-x8664-vinsn align-loop-head (() + () + ()) + (:align 4)) + (queue-fixup (fixup-x86-vinsn-templates Index: /branches/event-ide/ccl/compiler/X86/x86-arch.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/x86-arch.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/x86-arch.lisp (revision 8262) @@ -40,5 +40,5 @@ area-lock ; serialize access to gc exception-lock ; serialize exception handling - deleted-static-pairs ; hash-consing + static-conses ; when FREEZE is in effect default-allocation-quantum ; log2_heap_segment_size, as a fixnum. intflag ; interrupt-pending flag Index: /branches/event-ide/ccl/compiler/X86/x86-backend.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/x86-backend.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/x86-backend.lisp (revision 8262) @@ -316,6 +316,7 @@ (progn (list opname - (simplify-operand (car opvals))) - ) + (if (eq opname :anchored-uuo) + (simplify-form (car opvals)) + (simplify-operand (car opvals))))) (let* ((name (string opname))) (multiple-value-bind (opnum types) Index: /branches/event-ide/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/x86-disassemble.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/x86-disassemble.lisp (revision 8262) @@ -33,4 +33,8 @@ op2 ) + +(defmethod print-object ((xdi x86-disassembled-instruction) stream) + (print-unreadable-object (xdi stream :type t :identity t) + (format stream "~a" (x86-di-mnemonic xdi)))) (defstruct (x86-disassembly-state (:conc-name x86-ds-)) @@ -826,5 +830,7 @@ (defun nop-fixup (ds bytemode sizeflag) - (declare (ignore bytemode sizeflag)) + (declare (ignore bytemode sizeflag) + (ignorable ds)) + #+nothing (if (logtest (x86-ds-prefixes ds) +prefix-repz+) (break "should be PAUSE"))) @@ -2226,5 +2232,4 @@ (let* ((stop t)) (cond ((and (>= intop #x70) (< intop #x80)) - (setq stop nil) (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds))) (setf (x86-di-mnemonic instruction) Index: /branches/event-ide/ccl/compiler/X86/x86-lap.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/x86-lap.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/x86-lap.lisp (revision 8262) @@ -32,5 +32,5 @@ (progn (when (null (list-length data)) - (break "frag-vector freelist is circular")) + (compiler-bug "frag-vector freelist is circular")) (setf (pool.data *x86-lap-frag-vector-freelist*) (cdr data)) (rplacd data nil)) @@ -1015,55 +1015,66 @@ (finish-pending-talign-frag frag-list))))) -(defun x86-lap-directive (frag-list directive arg) - (if (eq directive :tra) - (progn - (finish-frag-for-align frag-list 3) - (x86-lap-directive frag-list :long `(:^ ,arg)) - (emit-x86-lap-label frag-list arg)) - (if (eq directive :fixed-constants) - (dolist (constant arg) - (ensure-x86-lap-constant-label constant)) - (if (eq directive :arglist) - (setq *x86-lap-lfun-bits* (encode-lambda-list arg)) - (let* ((exp (parse-x86-lap-expression arg)) - (constantp (or (constant-x86-lap-expression-p exp) - (not (x86-lap-expression-p exp))))) - - (if constantp - (let* ((val (x86-lap-expression-value exp))) - (ecase directive - (:code-size - (if *x86-lap-fixed-code-words* - (error "Duplicate :CODE-SIZE directive") - (setq *x86-lap-fixed-code-words* val))) - (:byte (frag-list-push-byte frag-list val)) - (:short (frag-list-push-16 frag-list val)) - (:long (frag-list-push-32 frag-list val)) - (:quad (frag-list-push-64 frag-list val)) - (:align (finish-frag-for-align frag-list val)) - (:talign (finish-frag-for-talign frag-list val)) - (:org (finish-frag-for-org frag-list val)))) - (let* ((pos (frag-list-position frag-list)) - (frag (frag-list-current frag-list)) - (reloctype nil)) - (ecase directive - (:byte (frag-list-push-byte frag-list 0) - (setq reloctype :expr8)) - (:short (frag-list-push-16 frag-list 0) - (setq reloctype :expr16)) - (:long (frag-list-push-32 frag-list 0) - (setq reloctype :expr32)) - (:quad (frag-list-push-64 frag-list 0) - (setq reloctype :expr64)) - (:align (error ":align expression ~s not constant" arg)) - (:talign (error ":talign expression ~s not constant" arg))) - (when reloctype - (push - (make-reloc :type reloctype - :arg exp - :pos pos - :frag frag) - (frag-relocs frag))))) - nil))))) +;;; Returns the active frag list after processing directive(s). +(defun x86-lap-directive (frag-list directive arg &optional main-frag-list exception-frag-list) + (declare (ignorable main-frag-list exception-frag-list)) + (case directive + (:tra + (finish-frag-for-align frag-list 3) + (x86-lap-directive frag-list :long `(:^ ,arg)) + (emit-x86-lap-label frag-list arg)) + (:fixed-constants + (dolist (constant arg) + (ensure-x86-lap-constant-label constant))) + (:arglist (setq *x86-lap-lfun-bits* (encode-lambda-list arg))) + ((:uuo :uuo-section) + (if exception-frag-list + (progn + (setq frag-list exception-frag-list) + (finish-frag-for-align frag-list 2)))) + ((:main :main-section) + (when main-frag-list (setq frag-list main-frag-list))) + (:anchored-uuo-section + (setq frag-list (x86-lap-directive frag-list :uuo-section nil main-frag-list exception-frag-list)) + (setq frag-list (x86-lap-directive frag-list :long `(:^ ,arg) main-frag-list exception-frag-list))) + (t (let* ((exp (parse-x86-lap-expression arg)) + (constantp (or (constant-x86-lap-expression-p exp) + (not (x86-lap-expression-p exp))))) + + (if constantp + (let* ((val (x86-lap-expression-value exp))) + (ecase directive + (:code-size + (if *x86-lap-fixed-code-words* + (error "Duplicate :CODE-SIZE directive") + (setq *x86-lap-fixed-code-words* val))) + (:byte (frag-list-push-byte frag-list val)) + (:short (frag-list-push-16 frag-list val)) + (:long (frag-list-push-32 frag-list val)) + (:quad (frag-list-push-64 frag-list val)) + (:align (finish-frag-for-align frag-list val)) + (:talign (finish-frag-for-talign frag-list val)) + (:org (finish-frag-for-org frag-list val)))) + (let* ((pos (frag-list-position frag-list)) + (frag (frag-list-current frag-list)) + (reloctype nil)) + (ecase directive + (:byte (frag-list-push-byte frag-list 0) + (setq reloctype :expr8)) + (:short (frag-list-push-16 frag-list 0) + (setq reloctype :expr16)) + (:long (frag-list-push-32 frag-list 0) + (setq reloctype :expr32)) + (:quad (frag-list-push-64 frag-list 0) + (setq reloctype :expr64)) + (:align (error ":align expression ~s not constant" arg)) + (:talign (error ":talign expression ~s not constant" arg))) + (when reloctype + (push + (make-reloc :type reloctype + :arg exp + :pos pos + :frag frag) + (frag-relocs frag)))))))) + frag-list) @@ -1081,5 +1092,5 @@ -(defun x86-lap-form (form frag-list instruction) +(defun x86-lap-form (form frag-list instruction main-frag-list exception-frag-list) (if (and form (symbolp form)) (emit-x86-lap-label frag-list form) @@ -1089,19 +1100,20 @@ (x86-lap-macroexpand-1 form) (if expanded - (x86-lap-form expansion frag-list instruction) + (x86-lap-form expansion frag-list instruction main-frag-list exception-frag-list) (if (typep (car form) 'keyword) - (destructuring-bind (op arg) form - (x86-lap-directive frag-list op arg)) + (destructuring-bind (op &optional arg) form + (setq frag-list (x86-lap-directive frag-list op arg main-frag-list exception-frag-list))) (case (car form) (progn (dolist (f (cdr form)) - (x86-lap-form f frag-list instruction))) + (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list)))) (let (destructuring-bind (equates &body body) (cdr form) - (x86-lap-equate-form equates frag-list instruction body))) + (setq frag-list (x86-lap-equate-form equates frag-list instruction body main-frag-list exception-frag-list)))) (t (parse-x86-instruction form instruction) - (x86-generate-instruction-code frag-list instruction))))))))) + (x86-generate-instruction-code frag-list instruction)))))))) + frag-list) (defun relax-align (address bits) @@ -1292,7 +1304,5 @@ (pad (- nextaddr (+ addr (frag-length frag))))) (unless (eql 0 pad) - (if (eq (car (frag-type frag)) :talign) - (frag-emit-nops frag pad) - (dotimes (i pad) (frag-push-byte frag #xcc))))))))) + (frag-emit-nops frag pad))))))) (defun show-frag-bytes (frag-list) @@ -1304,5 +1314,5 @@ (format t "~2,'0x " (frag-ref frag i))))) -(defun x86-lap-equate-form (eqlist fraglist instruction body) +(defun x86-lap-equate-form (eqlist fraglist instruction body main-frag exception-frag) (let* ((symbols (mapcar #'(lambda (x) (let* ((name (car x))) @@ -1322,6 +1332,6 @@ eqlist))) (progv symbols values - (dolist (form body) - (x86-lap-form form fraglist instruction))))) + (dolist (form body fraglist) + (setq fraglist (x86-lap-form form fraglist instruction main-frag exception-frag)))))) (defun cross-create-x86-function (name frag-list constants bits debug-info) @@ -1387,5 +1397,7 @@ (entry-code-tag (gensym)) (instruction (x86::make-x86-instruction)) - (frag-list (make-frag-list))) + (main-frag-list (make-frag-list)) + (exception-frag-list (make-frag-list)) + (frag-list main-frag-list)) (make-x86-lap-label end-code-tag) (make-x86-lap-label entry-code-tag) @@ -1396,7 +1408,10 @@ (x86-lap-directive frag-list :byte 0) ;regsave mask (emit-x86-lap-label frag-list entry-code-tag) - (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction) + + (x86-lap-form `(lea (@ (:^ ,entry-code-tag) (% rip)) (% fn)) frag-list instruction main-frag-list exception-frag-list) (dolist (f forms) - (x86-lap-form f frag-list instruction)) + (setq frag-list (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))) + (setq frag-list main-frag-list) + (merge-dll-nodes frag-list exception-frag-list) (x86-lap-directive frag-list :align 3) (when *x86-lap-fixed-code-words* Index: /branches/event-ide/ccl/compiler/X86/x86-lapmacros.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/x86-lapmacros.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/x86-lapmacros.lisp (revision 8262) @@ -27,39 +27,63 @@ (defx86lapmacro set-nargs (n) - (if (eql n 0) - `(xorw (% nargs) (% nargs)) - `(movw ($ ',n) (% nargs)))) + (cond ((>= n 16) `(movl ($ ',n) (% nargs.l))) + ((= n 0) `(xorl (% nargs.l) (% nargs.l))) + (t `(progn + (xorl (% nargs.l) (% nargs.l)) + (addl ($ ',n) (% nargs.l)))))) + + +(defx86lapmacro anchored-uuo (form) + `(progn + ,form + (:byte 0))) (defx86lapmacro check-nargs (min &optional (max min)) - (let* ((ok (gensym))) + (let* ((anchor (gensym)) + (bad (gensym))) (if (and max (= max min)) `(progn - (rcmp (% nargs) ($ ',min)) - (je.pt ,ok) - (uuo-error-wrong-number-of-args) - ,ok) + ,anchor + ,(if (eql min 0) + `(testw (% nargs) (% nargs)) + `(rcmp (% nargs) ($ ',min))) + (jne ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (anchored-uuo (uuo-error-wrong-number-of-args)) + (:main-section nil)) (if (null max) (unless (zerop min) `(progn + ,anchor (rcmp (% nargs) ($ ',min)) - (jae.pt ,ok) - (uuo-error-too-few-args) - ,ok)) + (jb ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (anchored-uuo (uuo-error-too-few-args)) + (:main-section nil))) (if (zerop min) `(progn + ,anchor (rcmp (% nargs) ($ ',max)) - (jb.pt ,ok) - (uuo-error-too-many-args) - ,ok) - (let* ((sofar (gensym))) + (ja ,bad) + (:anchored-uuo-section ,anchor) + ,bad + (anchored-uuo (uuo-error-too-many-args)) + (:main-section nil)) + (let* ((toofew (gensym)) + (toomany (gensym))) `(progn + ,anchor (rcmp (% nargs) ($ ',min)) - (jae.pt ,sofar) - (uuo-error-too-few-args) - ,sofar + (jb ,toofew) (rcmp (% nargs) ($ ',max)) - (jbe.pt ,ok) - (uuo-error-too-many-args) - ,ok))))))) + (ja ,toomany) + (:anchored-uuo-section ,anchor) + ,toofew + (anchored-uuo (uuo-error-too-few-args)) + (:anchored-uuo-section ,anchor) + ,toomany + (anchored-uuo (uuo-error-too-many-args))))))))) Index: /branches/event-ide/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/event-ide/ccl/compiler/X86/x862.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/X86/x862.lisp (revision 8262) @@ -40,5 +40,5 @@ (defparameter *x862-operator-supports-u8-target* ()) (defparameter *x862-operator-supports-push* ()) - +(defparameter *x862-tos-reg* ()) @@ -48,5 +48,5 @@ (if (eq (acode-operator x) (%nx1-operator immediate)) (cadr x) - (error "~&Bug: not an immediate: ~s" x))) + (compiler-bug "not an immediate: ~s" x))) (defmacro with-x86-p2-declarations (declsform &body body) @@ -67,9 +67,11 @@ (retvreg-var (gensym)) (label-var (gensym))) - `(macrolet ((! (,template-name-var &rest ,args-var) + `(macrolet ((! (,template-name-var &rest ,args-var) (let* ((,template-temp (get-vinsn-template-cell ,template-name-var (backend-p2-vinsn-templates *target-backend*)))) (unless ,template-temp (warn "VINSN \"~A\" not defined" ,template-name-var)) - `(%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var)))) + `(prog1 + (%emit-vinsn ,',segvar ',,template-name-var (backend-p2-vinsn-templates *target-backend*) ,@,args-var) + (setq *x862-tos-reg* nil))))) (macrolet ((<- (,retvreg-var) `(x862-copy-register ,',segvar ,',vreg-var ,,retvreg-var)) @@ -251,5 +253,5 @@ ((eq cell bottom) res) (if (null cell) - (error "Horrible compiler bug.") + (compiler-bug "Horrible compiler bug.") (if (eq (lcell-kind cell) kind) (push cell res))))) @@ -347,5 +349,5 @@ (defun x862-reverse-cr-bit (cr-bit) (or (svref *x862-reversed-cr-bits* cr-bit) - (error "Can't reverse CR bit ~d" cr-bit))) + (compiler-bug "Can't reverse CR bit ~d" cr-bit))) @@ -461,4 +463,5 @@ (1+ *x862-target-fixnum-shift*)))) (*x862-target-dnode-size* (* 2 *x862-target-lcell-size*)) + (*x862-tos-reg* nil) (*x862-all-lcells* ()) (*x862-top-vstack-lcell* nil) @@ -526,4 +529,5 @@ (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*) + (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*) (let* ((*x86-lap-labels* nil) (instruction (x86::make-x86-instruction)) @@ -537,5 +541,5 @@ (x86-lap-directive frag-list :byte 0) ;regsave mask - (x862-expand-vinsns vinsns frag-list instruction) + (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list) (when (or *x862-double-float-constant-alist* *x862-single-float-constant-alist*) @@ -605,5 +609,5 @@ #-x86-target (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))) - (x862-digest-symbols)))) + (x862-digest-symbols))))) (backend-remove-labels)))) afunc)) @@ -657,6 +661,6 @@ (if lap-label (x86-lap-label-address lap-label) - (error "Missing or bad ~s label: ~s" - (if start-p 'start 'end) sym))) + (compiler-bug "Missing or bad ~s label: ~s" + (if start-p 'start 'end) sym))) x8664::fulltag-function))) (destructuring-bind (var sym startlab endlab) info @@ -1100,10 +1104,10 @@ (x862-form seg nil nil f )) (apply fn seg vreg xfer (%cdr form))) - (error "x862-form ? ~s" form)))))) + (compiler-bug "x862-form ? ~s" form)))))) ;;; dest is a float reg - form is acode (defun x862-form-float (seg freg xfer form) (declare (ignore xfer)) - (when (or (nx-null form)(nx-t form))(error "x862-form to freg ~s" form)) + (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form)) (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double) (x862-form-typep form 'double-float)) @@ -1114,5 +1118,5 @@ (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (acode-operator form))))) (apply fn seg freg nil (%cdr form)) - (error "x862-form ? ~s" form)))) + (compiler-bug "x862-form ? ~s" form)))) @@ -1238,5 +1242,9 @@ (defun x862-stack-to-register (seg memspec reg) (with-x86-local-vinsn-macros (seg) - (! vframe-load reg (memspec-frame-address-offset memspec) *x862-vstack*))) + (let* ((offset (memspec-frame-address-offset memspec))) + (if (and *x862-tos-reg* + (= offset (- *x862-vstack* *x862-target-node-size*))) + (x862-copy-register seg reg *x862-tos-reg*) + (! vframe-load reg offset *x862-vstack*))))) (defun x862-lcell-to-register (seg lcell reg) @@ -2483,5 +2491,5 @@ (when tail-p #-no-compiler-bugs - (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (error "Well, well, well. How could this have happened ?")) + (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well. How could this have happened ?")) (when a-reg (x862-copy-register seg destreg a-reg)) @@ -2505,5 +2513,5 @@ (if (x862-mvpass-p xfer) (let* ((call-reg (if symp ($ x8664::fname) ($ x8664::temp0)))) - (unless mvpass-label (error "bug: no label for mvpass")) + (unless mvpass-label (compiler-bug "no label for mvpass")) (if label-p (x862-copy-register seg call-reg ($ x8664::fn)) @@ -2877,5 +2885,5 @@ ($ x8664::arg_z) (make-wired-lreg x8664::imm0 :mode mode))) - (t (error "Unknown register class for reg ~s" reg)))))) + (t (compiler-bug "Unknown register class for reg ~s" reg)))))) ;;; The compiler often generates superfluous pushes & pops. Try to @@ -3289,7 +3297,10 @@ (setq cr-bit (x862-reverse-cr-bit cr-bit))) (^ cr-bit true-p)) - (if (and (eq cr-bit x86::x86-e-bits) + (if (and ;(eq cr-bit x86::x86-e-bits) (or js32 is32)) - (x862-test-reg-%izerop + (progn + (unless (or js32 (eq cr-bit x86::x86-e-bits)) + (setq cr-bit (x862-reverse-cr-bit cr-bit))) + (x862-test-reg-%izerop seg vreg @@ -3301,5 +3312,5 @@ cr-bit true-p - (or js32 is32)) + (or js32 is32))) (multiple-value-bind (ireg jreg) (x862-two-untargeted-reg-forms seg i x8664::arg_y j x8664::arg_z) (x862-compare-registers seg vreg xfer ireg jreg cr-bit true-p))))))))) @@ -3374,4 +3385,27 @@ (^)))) +(defun x862-compare-register-to-constant (seg vreg xfer ireg cr-bit true-p constant) + (cond ((eq constant *nx-nil*) + (x862-compare-register-to-nil seg vreg xfer ireg cr-bit true-p)) + (t + (with-x86-local-vinsn-macros (seg vreg xfer) + (when vreg + (if (eq constant *nx-t*) + (! compare-to-t ireg) + (let* ((imm (x862-immediate-operand constant)) + (reg (x862-register-constant-p imm))) + (if reg + (! compare-registers reg ireg) + (! compare-constant-to-register (x86-immediate-label imm) ireg)))) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))))) + (defun x862-compare-register-to-nil (seg vreg xfer ireg cr-bit true-p) (with-x86-local-vinsn-macros (seg vreg xfer) @@ -3494,4 +3528,5 @@ (prog1 (! vpush-register src) + (setq *x862-tos-reg* src) (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info) (x862-adjust-vstack *x862-target-node-size*)))) @@ -3644,5 +3679,7 @@ (case src-mode (#.hard-reg-class-gpr-mode-node - (! unbox-u32 dest src)) + (if *x862-reckless* + (! %unbox-u32 dest src) + (! unbox-u32 dest src))) ((#.hard-reg-class-gpr-mode-u32 #.hard-reg-class-gpr-mode-s32) @@ -3660,5 +3697,7 @@ (case src-mode (#.hard-reg-class-gpr-mode-node - (! unbox-u16 dest src)) + (if *x862-reckless* + (! %unbox-u16 dest src) + (! unbox-u16 dest src))) ((#.hard-reg-class-gpr-mode-u8 #.hard-reg-class-gpr-mode-s8) @@ -3959,5 +3998,5 @@ (progn (when (%ilogbitp $vbitpunted bits) - (error "bind-var: var ~s was punted" var)) + (compiler-bug "bind-var: var ~s was punted" var)) (when make-vcell (with-node-target (x8664::allocptr) closed @@ -3995,5 +4034,5 @@ (not (logbitp $vbitpunted bits)))) (let ((endnote (%car (%cdddr (assq var *x862-recorded-symbols*))))) - (unless endnote (error "x862-close-var for ~s" (var-name var))) + (unless endnote (compiler-bug "x862-close-var for ~s" (var-name var))) (setf (vinsn-note-class endnote) :end-variable-scope) (append-dll-node (vinsn-note-label endnote) seg))))) @@ -4704,5 +4743,5 @@ (x862-decode-stack (aref *x862-undo-stack* target-catch)))) (if (%i< 0 (setq diff (%i- current-cstack target-cstack))) - (error "Bug: adjust foreign stack ?")) + (compiler-bug "Bug: adjust foreign stack ?")) (if (%i< 0 (setq diff (%i- current-vstack target-vstack))) (with-x86-local-vinsn-macros (seg) @@ -4979,5 +5018,5 @@ (incf num-c-frames)) (if (%i> cstack target-cstack) - (error "bug: adjust foreign stack ??")) + (compiler-bug "bug: adjust foreign stack ??")) ;; else what's going on? $sp-stkcons, for one thing (setq cstack target-cstack))) @@ -5020,5 +5059,5 @@ (declare (fixnum numopt nkeys numreq vtotal doadlword)) (when (or (> numreq 255) (> numopt 255) (> nkeys 255)) - (error "A lambda list can contain a maximum of 255 required, 255 optional, and 255 keywords args")) + (compiler-bug "A lambda list can contain a maximum of 255 required, 255 optional, and 255 keywords args")) (if (fixnump listform) (x862-store-ea seg listform argreg) @@ -5214,5 +5253,5 @@ -(defun x862-expand-vinsns (header frag-list instruction) +(defun x862-expand-vinsns (header frag-list instruction &optional uuo-frag-list) (let* ((immediate-operand (x86::make-x86-immediate-operand))) (do-dll-nodes (v header) @@ -5223,5 +5262,7 @@ (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v))) (x862-expand-note frag-list id))) - (x862-expand-vinsn v frag-list instruction immediate-operand)))) + (x862-expand-vinsn v frag-list instruction immediate-operand uuo-frag-list))) + (when uuo-frag-list + (merge-dll-nodes frag-list uuo-frag-list))) ;;; This doesn't have too much to do with anything else that's ;;; going on here, but it needs to happen before the lregs @@ -5244,6 +5285,7 @@ ;;; on entry, but it might be reasonable to make PARSE-OPERAND-FORM ;;; deal with lregs ... -(defun x862-expand-vinsn (vinsn frag-list instruction immediate-operand) +(defun x862-expand-vinsn (vinsn frag-list instruction immediate-operand &optional uuo-frag-list) (let* ((template (vinsn-template vinsn)) + (main-frag-list frag-list) (vp (vinsn-variable-parts vinsn)) (nvp (vinsn-template-nvp template)) @@ -5263,5 +5305,5 @@ (backend-lisp-context-register *target-backend*) (or (assq valform unique-labels) - (error + (compiler-bug "unknown vinsn label ~s" valform)))) ((atom valform) valform) @@ -5313,40 +5355,57 @@ (unless (eval-predicate pred) (return nil)))) - (t (error "Unknown predicate: ~s" f)))) + (t (compiler-bug "Unknown predicate: ~s" f)))) (expand-pseudo-op (f) - (destructuring-bind (directive arg) f - (setq arg (parse-operand-form arg)) - (let* ((exp (parse-x86-lap-expression arg)) - (constantp (or (not (x86-lap-expression-p exp)) - (constant-x86-lap-expression-p exp)))) - (if constantp - (let* ((val (x86-lap-expression-value exp))) - (ecase directive - (:byte (frag-list-push-byte frag-list val)) - (:short (frag-list-push-16 frag-list val)) - (:long (frag-list-push-32 frag-list val)) - (:quad (frag-list-push-64 frag-list val)) - (:align (finish-frag-for-align frag-list val)) - (:talign (finish-frag-for-talign frag-list val)))) - (let* ((pos (frag-list-position frag-list)) - (frag (frag-list-current frag-list)) - (reloctype nil)) - (ecase directive - (:byte (frag-list-push-byte frag-list 0) - (setq reloctype :expr8)) - (:short (frag-list-push-16 frag-list 0) - (setq reloctype :expr16)) - (:long (frag-list-push-32 frag-list 0) - (setq reloctype :expr32)) - (:quad (frag-list-push-64 frag-list 0) - (setq reloctype :expr64)) - ((:align :talign) (error "~s expression ~s not constant" directive arg))) - (when reloctype - (push - (make-reloc :type reloctype - :arg exp - :pos pos - :frag frag) - (frag-relocs frag)))))))) + (case (car f) + (:anchored-uuo-section + (expand-form '(:uuo-section)) + (expand-form `(:long (:^ ,(cadr f))))) + (:anchored-uuo + (expand-form (cadr f)) + ;; add a trailing 0 byte after the uu0 + (frag-list-push-byte frag-list 0)) + ((:uuo :uuo-section) + (if uuo-frag-list + (progn + (setq frag-list uuo-frag-list) + (finish-frag-for-align frag-list 2)) + (compiler-bug "No frag-list for :uuo"))) + ((:main :main-section) + (setq frag-list main-frag-list)) + (t + (destructuring-bind (directive arg) f + (setq arg (parse-operand-form arg)) + (let* ((exp (parse-x86-lap-expression arg)) + (constantp (or (not (x86-lap-expression-p exp)) + (constant-x86-lap-expression-p exp)))) + (if constantp + (let* ((val (x86-lap-expression-value exp))) + (ecase directive + (:byte (frag-list-push-byte frag-list val)) + (:short (frag-list-push-16 frag-list val)) + (:long (frag-list-push-32 frag-list val)) + (:quad (frag-list-push-64 frag-list val)) + (:align (finish-frag-for-align frag-list val)) + (:talign (finish-frag-for-talign frag-list val)))) + (let* ((pos (frag-list-position frag-list)) + (frag (frag-list-current frag-list)) + (reloctype nil)) + (ecase directive + (:byte (frag-list-push-byte frag-list 0) + (setq reloctype :expr8)) + (:short (frag-list-push-16 frag-list 0) + (setq reloctype :expr16)) + (:long (frag-list-push-32 frag-list 0) + (setq reloctype :expr32)) + (:quad (frag-list-push-64 frag-list 0) + (setq reloctype :expr64)) + ((:align :talign) (compiler-bug "~s expression ~s not constant" directive arg))) + (when reloctype + (push + (make-reloc :type reloctype + :arg exp + :pos pos + :frag frag) + (frag-relocs frag)))))))))) (expand-form (f) @@ -5354,5 +5413,5 @@ (emit-x86-lap-label frag-list (assq f unique-labels)) (if (atom f) - (error "Invalid form in vinsn body: ~s" f) + (compiler-bug "Invalid form in vinsn body: ~s" f) (if (atom (car f)) (if (keywordp (car f)) @@ -5736,5 +5795,5 @@ (defx862 x862-%primitive %primitive (seg vreg xfer &rest ignore) (declare (ignore seg vreg xfer ignore)) - (error "You're probably losing big: using %primitive ...")) + (compiler-bug "You're probably losing big: using %primitive ...")) (defx862 x862-consp consp (seg vreg xfer cc form) @@ -6112,11 +6171,28 @@ (^))) +(defun x862-eq-test (seg vreg xfer cc form1 form2) + (with-x86-local-vinsn-macros (seg) + (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) + (let* ((f1 (acode-unwrapped-form form1)) + (f2 (acode-unwrapped-form form2))) + (cond ((or (eq f1 *nx-nil*) + (eq f1 *nx-t*) + (and (acode-p f1) + (eq (acode-operator f1) (%nx1-operator immediate)))) + (x862-compare-register-to-constant seg vreg xfer (x862-one-untargeted-reg-form seg form2 ($ x8664::arg_z)) cr-bit true-p f1)) + ((or (eq f2 *nx-nil*) + (eq f2 *nx-t*) + (and (acode-p f2) + (eq (acode-operator f2) (%nx1-operator immediate)))) + (x862-compare-register-to-constant seg vreg xfer + (x862-one-untargeted-reg-form seg form1 ($ x8664::arg_z)) + cr-bit true-p f2)) + (t (x862-compare seg vreg xfer form1 form2 cr-bit true-p))))))) + (defx862 x862-eq eq (seg vreg xfer cc form1 form2) - (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) - (x862-compare seg vreg xfer form1 form2 cr-bit true-p))) + (x862-eq-test seg vreg xfer cc form1 form2)) (defx862 x862-neq neq (seg vreg xfer cc form1 form2) - (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) - (x862-compare seg vreg xfer form1 form2 cr-bit true-p))) + (x862-eq-test seg vreg xfer cc form1 form2)) (defx862 x862-numcmp numcmp (seg vreg xfer cc form1 form2) @@ -6221,13 +6297,12 @@ (and nil (format t "~& could use cell ~s for var ~s" cell (var-name varnode))) (if (logbitp x862-debug-verbose-bit *x862-debug-mask*) - (break "wrong ea for lcell for var ~s: got ~d, expected ~d" - (var-name varnode) (calc-lcell-offset cell) (logand ea-or-form #xffff)))) + (compiler-bug "wrong ea for lcell for var ~s: got ~d, expected ~d" + (var-name varnode) (calc-lcell-offset cell) (logand ea-or-form #xffff)))) (if (not cell) (when (memory-spec-p ea-or-form) (if (logbitp x862-debug-verbose-bit *x862-debug-mask*) - (format t "~& no lcell for ~s." (var-name varnode)))))) - + (compiler-bug "no lcell for ~s." (var-name varnode)))))) (unless (or (typep ea-or-form 'lreg) (fixnump ea-or-form)) - (break "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) + (compiler-bug "bogus ref to var ~s (~s) : ~s " varnode (var-name varnode) ea-or-form)) (x862-do-lexical-reference seg vreg ea-or-form) (^))))) @@ -6235,5 +6310,5 @@ (defx862 x862-setq-lexical setq-lexical (seg vreg xfer varspec form) (let* ((ea (var-ea varspec))) - ;(unless (fixnump ea) (break "setq lexical is losing BIG")) + ;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) (or (null vreg) (eq ea vreg))) @@ -6264,5 +6339,5 @@ (if (= class hard-reg-class-crf) (progn - ;(break "Would have clobbered a GPR!") + ;compiler-bug "Would have clobbered a GPR!") (x862-branch seg (x862-cd-true xfer))) (progn @@ -6330,4 +6405,5 @@ (if (eq (acode-operator form) tagop) (let ((tag (cddr form))) + (when (cddr tag) (! align-loop-head)) (@ (car tag))) (x862-form seg nil nil form))) @@ -6983,9 +7059,18 @@ (with-x86-local-vinsn-macros (seg vreg xfer) (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc) - (! mask-base-char x8664::imm0 (x862-one-untargeted-reg-form seg form x8664::arg_z)) - (x862-test-reg-%izerop seg vreg xfer x8664::imm0 cr-bit true-p - (target-arch-case - - (:x8664 x8664::subtag-character)))))) + (! compare-u8-constant (x862-one-untargeted-reg-form seg form x8664::arg_z) + (target-arch-case + (:x8664 x8664::subtag-character))) + (setq cr-bit (x862-cr-bit-for-unsigned-comparison cr-bit)) + (regspec-crf-gpr-case + (vreg dest) + (^ cr-bit true-p) + (progn + (ensuring-node-target (target dest) + (if (not true-p) + (setq cr-bit (logxor 1 cr-bit))) + (! cr-bit->boolean target cr-bit)) + (^)))))) + @@ -8073,5 +8158,5 @@ (progn (unless (logbitp (hard-regspec-value vreg) *backend-imm-temps*) - (error "I give up. When will I get this right ?")) + (compiler-bug "I give up. When will I get this right ?")) (let* ((natural-reg (x862-one-targeted-reg-form seg form @@ -8725,5 +8810,5 @@ (with-imm-target (xreg) (yreg :natural) (x862-two-targeted-reg-forms seg x xreg y yreg) - (! %natural- xreg yreg)) + (! %natural- xreg yreg)) (<- xreg)) (progn Index: /branches/event-ide/ccl/compiler/acode-rewrite.lisp =================================================================== --- /branches/event-ide/ccl/compiler/acode-rewrite.lisp (revision 8262) +++ /branches/event-ide/ccl/compiler/acode-rewrite.lisp (revision 8262) @@ -0,0 +1,379 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(defvar *acode-post-trust-decls* nil) + +;;; Rewrite acode trees. + +(next-nx-defops) +(defvar *acode-rewrite-functions* nil) +(let* ((newsize (%i+ (next-nx-num-ops) 10)) + (old *acode-rewrite-functions*) + (oldsize (length old))) + (declare (fixnum newsize oldsize)) + (unless (>= oldsize newsize) + (let* ((v (make-array newsize :initial-element nil))) + (dotimes (i oldsize (setq *acode-rewrite-functions* v)) + (setf (svref v i) (svref old i)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-acode-rewrite (name operator-list arglist &body body) + (if (atom operator-list) + (setq operator-list (list operator-list))) + (multiple-value-bind (body decls) + (parse-body body nil t) + (collect ((let-body)) + (dolist (operator operator-list) + (let-body `(setf (svref *acode-rewrite-functions* (logand operator-id-mask (%nx1-operator ,operator))) fun))) + (destructuring-bind (op whole type) arglist + `(let* ((fun (nfunction ,name + (lambda (,op ,whole ,type) + (declare (ignorable ,op ,type)) + ,@decls + (block ,name ,@body))))) + ,@(let-body))))))) + +;;; Don't walk the form (that's already happened.) +(defun acode-post-form-type (form) + (when (acode-p form) + (let* ((op (acode-operator form)) + (operands (cdr form))) + (cond ((and *acode-post-trust-decls* + (eq op (%nx1-operator typed-form))) + (acode-operand 0 operands)) + ((eq op (%nx1-operator fixnum)) + 'fixnum) + ((eq op (%nx1-operator immediate)) + (type-of (acode-operand 0 operands))) + (t t))))) + +(defun acode-constant-p (form) + (let* ((form (acode-unwrapped-form form))) + (or (eq form *nx-nil*) + (eq form *nx-t*) + (let* ((operator (if (acode-p form) (acode-operator form)))) + (or (eq operator (%nx1-operator fixnum)) + (eq operator (%nx1-operator immediate))))))) + +(defun acode-post-form-typep (form type) + (let* ((ctype (specifier-type type)) + (form (acode-unwrapped-form form))) + (cond ((eq form *nx-nil*) (ctypep nil ctype)) + ((eq form *nx-t*) (ctypep t ctype)) + ((not (acode-p form)) (values nil nil)) + (t + (let* ((op (acode-operator form)) + (operands (cdr form))) + (cond ((and *acode-post-trust-decls* + (eq op (%nx1-operator typed-form))) + (subtypep (acode-operand 0 operands) type)) + ((or (eq op (%nx1-operator fixnum)) + (eq op (%nx1-operator immediate))) + (ctypep (acode-operand 0 operands) (specifier-type type))) + (t (values nil nil)))))))) + + + +(defun rewrite-acode-ref (ref &optional (type t)) + (let* ((form (car ref))) + (if (acode-p form) + (let* ((op (acode-operator form)) + (rewrite (svref *acode-rewrite-functions* (logand op operator-id-mask)))) + (when rewrite + (let* ((new (funcall rewrite op (cdr form) type))) + (when new + (setf (car ref) new) + t))))))) + +;;; Maybe ewrite the operands of a binary real arithmetic operation +(defun acode-post-binop-numeric-contagion (pform1 pform2) + (let* ((form1 (car pform1)) + (form2 (car pform2))) + (cond ((acode-post-form-typep form1 'double-float) + (unless (acode-post-form-typep form2 'double-float) + (let* ((c2 (acode-real-constant-p form2))) + (if c2 + (setf (car pform2) + (make-acode (%nx1-operator immediate) + (float c2 0.0d0))) + (if (acode-post-form-typep form2 'fixnum) + (setf (car pform2) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode (%nx1-operator %fixnum-to-double) + form2)))))))) + ((acode-post-form-typep form2 'double-float) + (let* ((c1 (acode-real-constant-p form1))) + (if c1 + (setf (car pform1) + (make-acode (%nx1-operator immediate) + (float c1 0.0d0))) + (if (acode-post-form-typep form1 'fixnum) + (setf (car pform1) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode (%nx1-operator %fixnum-to-double) + form1))))))) + ((acode-post-form-typep form1 'single-float) + (unless (acode-post-form-typep form2 'single-float) + (let* ((c2 (acode-real-constant-p form2))) + (if c2 + (setf (car pform2) (make-acode (%nx1-operator immediate) + (float c2 0.0f0))) + (if (acode-post-form-typep form2 'fixnum) + (setf (car pform2) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode (%nx1-operator %fixnum-to-single) + form2)))))))) + ((acode-post-form-typep form2 'single-float) + (let* ((c1 (acode-real-constant-p form1))) + (if c1 + (setf (car pform1) (make-acode (%nx1-operator immediate) + (float c1 0.0f0))) + + (if (acode-post-form-typep form1 'fixnum) + (setf (car pform1) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode (%nx1-operator %fixnum-to-single) + form1)))))))))) + +(defun constant-fold-acode-binop (function x y) + (let* ((constant-x (acode-real-constant-p x)) + (constant-y (acode-real-constant-p y))) + (if (and constant-x constant-y) + (let* ((result (ignore-errors (funcall function x y)))) + (when result + (nx1-form result)))))) + +(defun acode-rewrite-and-fold-binop (function args) + (rewrite-acode-ref args) + (rewrite-acode-ref (cdr args)) + (constant-fold-acode-binop function (car args) (cadr args))) + +(defun rewrite-acode-forms (forms) + (do* ((head forms (cdr head))) + ((null head)) + (rewrite-acode-ref head))) + +(defun acode-assert-type (actualtype operator operands assertedtype) + (make-acode (%nx1-operator typed-form) + (type-specifier (type-intersection (specifier-type actualtype) + (specifier-type assertedtype))) + (cons operator operands))) + +(def-acode-rewrite acode-rewrite-progn progn (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-not not (op w type) + (rewrite-acode-ref w)) + +(def-acode-rewrite acode-rewrite-%i+ %i+ (op w type) + (or + (acode-rewrite-and-fold-binop '+ w) + ;; TODO: maybe cancel overflow check, assert FIXNUM result. + (acode-assert-type 'integer op w type))) + +(def-acode-rewrite acode-rewrite-%i- %i- (op w type) + (or + (acode-rewrite-and-fold-binop '- w)) + ;; TODO: maybe cancel overflow check, assert FIXNUM result. + (acode-assert-type 'integer op w type)) + +(def-acode-rewrite acode-rewrite-%ilsl %ilsl (op w type) + (or + (acode-rewrite-and-fold-binop '%ilsl w) + (acode-assert-type 'fixnum op w type))) + +(def-acode-rewrite acode-rewrite-%ilogand2 %ilogand2 (op w type) + (or + (acode-rewrite-and-fold-binop 'logand w) + ;; If either argument's an UNSIGNED-BYTE constant, the result + ;; is an UNSIGNED-BYTE no greater than that constant. + (destructuring-bind (x y) w + (let* ((fix-x (acode-fixnum-form-p x)) + (fix-y (acode-fixnum-form-p y))) + (acode-assert-type (if fix-x + `(integer 0 ,fix-x) + (if fix-y + `(integer 0 ,fix-y) + 'fixnum)) + op w type))))) + +(def-acode-rewrite acode-rewrite-%ilogior2 %ilogior2 (op w type) + (or + (acode-rewrite-and-fold-binop 'logior w) + ;; If either argument's an UNSIGNED-BYTE constant, the result + ;; is an UNSIGNED-BYTE no greater than that constant. + (destructuring-bind (x y) w + (let* ((fix-x (acode-fixnum-form-p x)) + (fix-y (acode-fixnum-form-p y))) + (acode-assert-type (if fix-x + `(integer 0 ,fix-x) + (if fix-y + `(integer 0 ,fix-y) + 'fixnum)) + op w type))))) + +(def-acode-rewrite acode-rewrite-ilogbitp (logbitp %ilogbitp) (op w type) + (or (acode-rewrite-and-fold-binop 'logbitp w) + (acode-assert-type 'boolean op w type))) + +(def-acode-rewrite acode-rewrite-eq eq (op w type) + (or (acode-rewrite-and-fold-binop 'eq w) + (acode-assert-type 'boolean op w type))) + +(def-acode-rewrite acode-rewrite-neq neq (op w type) + (or (acode-rewrite-and-fold-binop 'neq w) + (acode-assert-type 'boolean op w type)) ) + +(def-acode-rewrite acode-rewrite-list list (op w type) + (rewrite-acode-forms (car w)) + (acode-assert-type 'list op w type)) + +(def-acode-rewrite acode-rewrite-values values (op w type) + (rewrite-acode-forms (car w))) + +(def-acode-rewrite acode-rewrite-if if (op w type) + (rewrite-acode-forms w) + (destructuring-bind (test true &optional (false *nx-nil*)) w + (if (acode-constant-p test) + (if (eq *nx-nil* (acode-unwrapped-form test)) + false + true)))) + +(def-acode-rewrite acode-rewrite-or or (op w type) + (rewrite-acode-forms (car w)) + ;; Try to short-circuit if there are any true constants. + ;; The constant-valued case will return a single value. + (do* ((forms w (cdr forms))) + ((null (cdr forms))) + (let* ((form (car forms))) + (when (and (acode-constant-p form) + (not (eq *nx-nil* (acode-unwrapped-form form)))) + (progn + (rplacd forms nil) + (return)))))) + +(def-acode-rewrite acode-rewrite-%fixnum-ref (%fixnum-ref %fixnum-ref-natural) (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-multiple-value-prog1 multiple-value-prog1 (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-multiple-value-bind multiple-value-bind (op w type) + (rewrite-acode-forms (cdr w))) + +(def-acode-rewrite acode-rewrite-multiple-value-call multiple-value-call (op w type) + (rewrite-acode-forms w)) + +(def-acode-rewrite acode-rewrite-typed-form typed-form (op w type) + (let* ((ourtype (car w))) + (rewrite-acode-ref (cdr w) ourtype) + (let* ((subform (cadr w))) + (and (acode-p subform) (eq (acode-operator subform) op) subform)))) + +;; w: vars, list of initial-value forms, body +(def-acode-rewrite acode-rewrite-let (let let*) (op w type) + (collect ((newvars) + (newvals)) + (do* ((vars (car w) (cdr vars)) + (vals (cadr w) (cdr vals))) + ((null vars) + (rplaca w (newvars)) + (rplaca (cdr w) (newvals)) + (rewrite-acode-ref (cddr w)) + (unless (car w) (caddr w))) + (rewrite-acode-ref (car vals)) + (let* ((var (car vars)) + (bits (nx-var-bits var))) + (cond ((logbitp $vbitpuntable bits) + (setf (var-bits var) + (logior (ash 1 $vbitpunted) bits) + (var-ea var) (car vals))) + (t + (newvars var) + (newvals (car vals)))))))) + + + + + + +(def-acode-rewrite acode-rewrite-lexical-reference lexical-reference (op w type) + (let* ((var (car w))) + (if (acode-punted-var-p var) + (var-ea var)))) + +(def-acode-rewrite acode-rewrite-add2 add2 (op w type) + (or (acode-rewrite-and-fold-binop '+ w) + (progn + (acode-post-binop-numeric-contagion w (cdr w)) + (let* ((xtype (acode-post-form-type (car w))) + (ytype (acode-post-form-type (cadr w)))) + (cond ((and (subtypep xtype 'double-float) + (subtypep ytype 'double-float)) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode* (%nx1-operator %double-float+-2) + w))) + ((and (subtypep xtype 'single-float) + (subtypep ytype 'single-float)) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode* (%nx1-operator %short-float+-2) + w))) + ((and (subtypep xtype 'fixnum) + (subtypep ytype 'fixnum)) + (make-acode (%nx1-operator typed-form) + 'fixnum + (make-acode (%nx1-operator %i+) + (car w) + (cadr w) + (not (subtypep type 'fixnum)))))))))) + +(def-acode-rewrite acode-rewrite-sub2 sub2 (op w type) + (or (acode-rewrite-and-fold-binop '- w) + (progn + (acode-post-binop-numeric-contagion w (cdr w)) + (let* ((xtype (acode-post-form-type (car w))) + (ytype (acode-post-form-type (cadr w)))) + (cond ((and (subtypep xtype 'double-float) + (subtypep ytype 'double-float)) + (make-acode (%nx1-operator typed-form) + 'double-float + (make-acode* (%nx1-operator %double-float--2) + w))) + ((and (subtypep xtype 'single-float) + (subtypep ytype 'single-float)) + (make-acode (%nx1-operator typed-form) + 'single-float + (make-acode* (%nx1-operator %short-float--2) + w))) + ((and (subtypep xtype 'fixnum) + (subtypep ytype 'fixnum)) + (make-acode (%nx1-operator typed-form) + 'fixnum + (make-acode (%nx1-operator %i-) + (car w) + (cadr w) + (not (subtypep type 'fixnum)))))))))) + + Index: /branches/event-ide/ccl/compiler/arch.lisp =================================================================== --- /branches/event-ide/ccl/compiler/arch.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/arch.lisp (revision 8262) @@ -28,4 +28,10 @@ (defconstant tcr-flag-bit-foreign 0) (defconstant tcr-flag-bit-awaiting-preset 1) +(defconstant tcr-flag-bit-alt-suspend 2) +(defconstant tcr-flag-bit-propagate-exception 3) +(defconstant tcr-flag-bit-suspend-ack-pending 4) +(defconstant tcr-flag-bit-pending-exception 5) +(defconstant tcr-flag-bit-foreign-exception 6) +(defconstant tcr-flag-bit-pending-suspend 7) @@ -52,4 +58,5 @@ (defconstant error-cant-take-car 8) (defconstant error-cant-take-cdr 9) +(defconstant error-propagate-suspend 10) (defconstant error-cant-call 17) ; Attempt to funcall something that is not a symbol or function. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -323,4 +330,7 @@ (defconstant gc-trap-function-configure-egc 64) (defconstant gc-trap-function-set-hons-area-size 128) +(defconstant gc-trap-function-freeze 129) +(defconstant gc-trap-function-thaw 130) + Index: /branches/event-ide/ccl/compiler/nx.lisp =================================================================== --- /branches/event-ide/ccl/compiler/nx.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/nx.lisp (revision 8262) @@ -204,10 +204,9 @@ - - - - -#+ppc-target -(require "PPC2") +(defun compiler-bug (format &rest args) + (error (make-condition 'compiler-bug + :format-control format + :format-arguments args))) + (defparameter *nx-end* (cons nil nil)) Index: /branches/event-ide/ccl/compiler/nx0.lisp =================================================================== --- /branches/event-ide/ccl/compiler/nx0.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/nx0.lisp (revision 8262) @@ -133,4 +133,5 @@ (#.(%nx1-operator %fixnum-to-single) . single-float) (#.(%nx1-operator %fixnum-to-double) . double-float) + (#.(%nx1-operator char-code) . #.`(integer 0 (,char-code-limit))) )) @@ -139,5 +140,6 @@ (%ilogxor . fixnum) (%ilogand . fixnum) - (%ilogior . fixnum))) + (%ilogior . fixnum) + (char-code . #. `(integer 0 (,char-code-limit))))) (setq *nx-known-declarations* @@ -979,5 +981,4 @@ (let* ((bits (nx-var-bits var)) (mask (%ilogior (%ilsl $vbitsetq 1) (ash -1 $vbitspecial) (%ilsl $vbitclosed 1))) - ;(count (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits)))) (nrefs (%ilogand $vrefmask bits)) (val (nx-untyped-form initform)) @@ -986,11 +987,11 @@ (if (or - ;(%izerop count) ; unreferenced vars can still have side effects (nx-t val) (nx-null val) - (and (eql nrefs 1) ( acode-absolute-ptr-p val t)) + (and (eql nrefs 1) (not (logbitp $vbitdynamicextent bits)) ( acode-absolute-ptr-p val t)) (eq op (%nx1-operator fixnum)) (eq op (%nx1-operator immediate))) - (nx-set-var-bits var (%ilogior (%ilsl $vbitpuntable 1) bits)))) + (progn + (nx-set-var-bits var (%ilogior (%ilsl $vbitpuntable 1) bits))))) (when (and (%ilogbitp $vbitdynamicextent bits) (or (eq op (%nx1-operator closed-function)) @@ -1219,5 +1220,4 @@ (boundtobits (nx-var-bits boundto))) (declare (fixnum varbits boundtobits)) - (unless (eq (%ilogior (%ilsl $vbitsetq 1) @@ -1228,5 +1228,5 @@ (%ilsl $vbitclosed 1)) boundtobits)) - ; Can't happen - + ;; Can't happen - (unless (%izerop (%ilogand (%ilogior (%ilsl $vbitsetq 1) Index: /branches/event-ide/ccl/compiler/nx1.lisp =================================================================== --- /branches/event-ide/ccl/compiler/nx1.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/nx1.lisp (revision 8262) @@ -1661,6 +1661,6 @@ (%nx1-operator %immediate-set-xxx) (case op - (%%set-signed-longlong (logior 32 8)) - (t 8)) + (%%set-signed-longlong 8) + (t (logior 32 8))) (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr)) (nx1-form offset) Index: /branches/event-ide/ccl/compiler/optimizers.lisp =================================================================== --- /branches/event-ide/ccl/compiler/optimizers.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/optimizers.lisp (revision 8262) @@ -135,25 +135,22 @@ t)) -;;; return new form if no keys (or if keys constant and specify :TEST -;;; {#'eq, #'eql} only.) -(defun eq-eql-call (x l keys eq-fn eql-fn env) - (flet ((eql-to-eq () - (or (eql-iff-eq-p x env) - (and (or (quoted-form-p l) (null l)) - (dolist (elt (%cadr l) t) - (when (eq eq-fn 'assq) (setq elt (car elt))) - (when (and (numberp elt) (not (fixnump elt))) - (return nil))))))) - (if (null keys) - (list (if (eql-to-eq) eq-fn eql-fn) x l) - (if (constant-keywords-p keys) +(defun remove-explicit-test-keyword-from-test-testnot-key (item list keys default alist testonly) + (if (null keys) + `(,default ,item ,list) + (if (constant-keywords-p keys) (destructuring-bind (&key (test nil test-p) (test-not nil test-not-p) (key nil key-p)) keys - (declare (ignore test-not key)) + (declare (ignore test-not)) (if (and test-p - (not test-not-p) - (not key-p) + (not test-not-p) + (or (not key-p) + (and (consp key) + (consp (%cdr key)) + (null (%cddr key)) + (or (eq (%car key) 'function) + (eq (%car key) 'quote)) + (eq (%cadr key) 'identity))) (consp test) (consp (%cdr test)) @@ -161,11 +158,10 @@ (or (eq (%car test) 'function) (eq (%car test) 'quote))) - (let ((testname (%cadr test))) - (if (or (eq testname 'eq) - (and (eq testname 'eql) - (eql-to-eq))) - (list eq-fn x l) - (if (and eql-fn (eq testname 'eql)) - (list eql-fn x l)))))))))) + (let* ((testname (%cadr test)) + (reduced (cdr (assoc testname alist)))) + (if reduced + `(,reduced ,item ,list) + `(,testonly ,item ,list ,test)))))))) + (defun eql-iff-eq-p (thing env) @@ -174,11 +170,24 @@ (if (not (self-evaluating-p thing)) (return-from eql-iff-eq-p - (nx-form-typep thing - '(or fixnum - #+64-bit-target single-float - character symbol - (and (not number) (not macptr))) env)))) + (or (nx-form-typep thing 'symbol env) + (nx-form-typep thing 'character env) + (nx-form-typep thing + '(or fixnum + #+64-bit-target single-float + symbol character + (and (not number) (not macptr))) env))))) (or (fixnump thing) #+64-bit-target (typep thing 'single-float) + (symbolp thing) (characterp thing) (and (not (numberp thing)) (not (macptrp thing))))) + +(defun equal-iff-eql-p (thing env) + (if (quoted-form-p thing) + (setq thing (%cadr thing)) + (if (not (self-evaluating-p thing)) + (return-from equal-iff-eql-p + (nx-form-typep thing + '(and (not cons) (not string) (not bit-vector) (not pathname)) env)))) + (not (typep thing '(or cons string bit-vector pathname)))) + (defun fold-constant-subforms (call env) @@ -310,28 +319,70 @@ (define-compiler-macro apply (&whole call &environment env fn arg0 &rest args) - (let ((original-fn fn)) - (if (and arg0 - (null args) - (consp fn) - (eq (%car fn) 'function) - (null (cdr (%cdr fn))) - (consp (setq fn (%cadr fn))) - (eq (%car fn) 'lambda)) - (destructuring-bind (lambda-list &body body) (%cdr fn) - `(destructuring-bind ,lambda-list ,arg0 ,@body)) - (let ((last (%car (last (push arg0 args))))) - (if (and (consp last) (memq (%car last) '(cons list* list))) - (cons (if (eq (%car last) 'list) 'funcall 'apply) - (cons - original-fn - (nreconc (cdr (reverse args)) (%cdr last)))) - call))))) - - - -(define-compiler-macro assoc (&whole call &environment env item list &rest keys) - (or (eq-eql-call item list keys 'assq 'asseql env) + ;; Special-case (apply #'make-instance 'name ...) + ;; Might be good to make this a little more general, e.g., there + ;; may be other things that can be strength-reduced even if we can't + ;; get rid of the APPLY. + (if (and (consp fn) + (or (eq (car fn) 'quote) + (eq (car fn) 'function)) + (consp (cdr fn)) + (null (cddr fn)) + (eq (cadr fn) 'make-instance) + (consp arg0) + (eq (car arg0) 'quote) + (consp (cdr arg0)) + (symbolp (cadr arg0))) + (let* ((name (cadr arg0)) + (class-cell (gensym))) + `(let* ((,class-cell (load-time-value (find-class-cell ',name t)))) + (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args))) + (let ((original-fn fn)) + (if (and arg0 + (null args) + (consp fn) + (eq (%car fn) 'function) + (null (cdr (%cdr fn))) + (consp (setq fn (%cadr fn))) + (eq (%car fn) 'lambda)) + (destructuring-bind (lambda-list &body body) (%cdr fn) + `(destructuring-bind ,lambda-list ,arg0 ,@body)) + (let ((last (%car (last (push arg0 args))))) + (if (and (consp last) (memq (%car last) '(cons list* list))) + (cons (if (eq (%car last) 'list) 'funcall 'apply) + (cons + original-fn + (nreconc (cdr (reverse args)) (%cdr last)))) + call)))))) + + + +(define-compiler-macro assoc (&whole call item list &rest keys) + (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'asseql '((eq . assq) (eql . asseql) (equal . assequal)) 'assoc-test) call)) +(define-compiler-macro assequal (&whole call &environment env item list) + (if (or (equal-iff-eql-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (x) (equal-iff-eql-p (car x) env)) (%cadr list)))) + `(asseql ,item ,list) + call)) + +(define-compiler-macro asseql (&whole call &environment env item list) + (if (or (eql-iff-eq-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (x) (eql-iff-eq-p (car x) env)) (%cadr list)))) + `(assq ,item ,list) + call)) + +(define-compiler-macro assq (item list) + (let* ((itemx (gensym)) + (listx (gensym)) + (pair (gensym))) + `(let* ((,itemx ,item) + (,listx ,list)) + (dolist (,pair ,listx) + (when (and ,pair (eq (car ,pair) ,itemx)) (return ,pair)))))) (define-compiler-macro caar (form) @@ -748,6 +799,7 @@ (symbolp (cadr class)) (null (cddr class))) - `(%make-instance (load-time-value (find-class-cell ,class t)) - ,@initargs) + (let* ((cell (gensym))) + `(let* ((,cell (load-time-value (find-class-cell ,class t)))) + (funcall (class-cell-instantiate ,cell) ,cell ,@initargs))) call)) @@ -785,17 +837,38 @@ (setq ,temp-var (setf (cdr ,temp-var) (list (funcall ,fn-var ,elt-var))))))))) -(define-compiler-macro member (&whole call &environment env item list &rest keys) - (or (eq-eql-call item list keys 'memq 'memeql env) +(define-compiler-macro member (&whole call item list &rest keys) + (or (remove-explicit-test-keyword-from-test-testnot-key item list keys 'memeql '((eq . memq) (eql . memeql) (equal . memequal)) 'member-test) call)) +(define-compiler-macro memequal (&whole call &environment env item list) + (if (or (equal-iff-eql-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (elt) (equal-iff-eql-p elt env)) (%cadr list)))) + `(memeql ,item ,list) + call)) + +(define-compiler-macro memeql (&whole call &environment env item list) + (if (or (eql-iff-eq-p item env) + (and (quoted-form-p list) + (proper-list-p (%cadr list)) + (every (lambda (elt) (eql-iff-eq-p elt env)) (%cadr list)))) + `(memq ,item ,list) + call)) + (define-compiler-macro memq (&whole call &environment env item list) - ;(memq x '(y)) => (if (eq x 'y) '(y)) - ;Would it be worth making a two elt list into an OR? Maybe if - ;optimizing for speed... + ;;(memq x '(y)) => (if (eq x 'y) '(y)) + ;;Would it be worth making a two elt list into an OR? Maybe if + ;;optimizing for speed... (if (and (or (quoted-form-p list) (null list)) (null (cdr (%cadr list)))) (if list `(if (eq ,item ',(%caadr list)) ,list)) - call)) + (let* ((x (gensym)) + (tail (gensym))) + `(do* ((,x ,item) + (,tail ,list (cdr (the list ,tail)))) + ((null ,tail)) + (if (eq (car ,tail) ,x) (return ,tail)))))) (define-compiler-macro minusp (x) @@ -815,5 +888,5 @@ (%i< count 3)) `(,(svref '#(car cadr caddr) count) ,list) - call)) + `(car (nthcdr ,count ,list)))) (define-compiler-macro nthcdr (&whole call &environment env count list) @@ -822,7 +895,14 @@ (%i< count 4)) (if (%izerop count) - list + `(require-type ,list 'list) `(,(svref '#(cdr cddr cdddr) (%i- count 1)) ,list)) - call)) + (let* ((i (gensym)) + (n (gensym)) ; evaluation order + (tail (gensym))) + `(let* ((,n (require-type ,count 'unsigned-byte)) + (,tail (require-type ,list 'list))) + (dotimes (,i ,n ,tail) + (unless (setq ,tail (cdr ,tail)) + (return nil))))))) (define-compiler-macro plusp (x) @@ -839,6 +919,7 @@ ;;; ( foo)). (define-compiler-macro require-type (&whole call &environment env arg type) - (cond ((and (quoted-form-p type) - (setq type (%cadr type)) + (cond ((and (or (eq type t) + (and (quoted-form-p type) + (setq type (%cadr type)))) (not (typep (specifier-type type) 'unknown-ctype))) (cond ((nx-form-typep arg type env) arg) @@ -884,14 +965,17 @@ ((type= (specifier-type type) (specifier-type '(unsigned-byte 64))) - `(the (unsigned-byte 64) (require-u64 ,arg))) - ((and (consp type)(memq (car type) '(signed-byte unsigned-byte integer))) - `(the ,type (%require-type-builtin ,arg - (load-time-value (find-builtin-cell ',type))))) + `(the (unsigned-byte 64) (require-u64 ,arg))) + #+nil ((and (symbolp type) (let ((simpler (type-predicate type))) (if simpler `(the ,type (%require-type ,arg ',simpler)))))) + #+nil ((and (symbolp type)(find-class type nil env)) `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t)))) - (t call))) + (t (let* ((val (gensym))) + `(let* ((,val ,arg)) + (if (typep ,val ',type) + ,val + (%kernel-restart $xwrongtype ,val ',type))))))) (t call))) @@ -1308,55 +1392,152 @@ (null (%cdr (%cdr form))))) + +;; Return a form that checks to see if THING is if type CTYPE, or +;; NIL if we can't do that for some reason. +(defun optimize-ctypep (thing ctype) + (when (eq *target-backend* *host-backend*) + (typecase ctype + (numeric-ctype + (cond ((eq :real (numeric-ctype-complexp ctype)) + (let* ((low (numeric-ctype-low ctype)) + (high (numeric-ctype-high ctype)) + (class (numeric-ctype-class ctype)) + (format (numeric-ctype-format ctype)) + (type (if (eq class 'float) + (or format class) + class))) + (cond ((and low (eql low high) (or (not (eq class 'float)) + format)) + `(eql ,thing ,low)) + ((and (eq type 'float) + (or low high) + (or (null low) + (typep low 'single-float) + (not (null (ignore-errors + (coerce (if (atom low) + low + (car low)) + 'single-float))))) + (or (null high) + (typep high 'single-float) + (not (null (ignore-errors + (coerce (if (atom high) + high + (car high)) + 'single-float)))))) + (let* ((temp (gensym))) + (flet ((bounded-float (type low high) + `(,type + ,(if low + (if (listp low) + (list (coerce (car low) type)) + (coerce low type)) + '*) + ,(if high + (if (listp high) + (list (coerce (car high) type)) + (coerce high type)) + '*)))) + `(let* ((,temp ,thing)) + (or (typep ,temp ',(bounded-float 'single-float low high)) + (typep ,temp ',(bounded-float 'double-float low high))))))) + (t + (let* ((temp (gensym))) + (if (and (typep low 'fixnum) (typep high 'fixnum)) + (setq type 'fixnum)) + (if (or low high) + `(let* ((,temp ,thing)) + (and (typep ,temp ',type) + ,@(if low `((,(if (consp low) '> '>=) (the ,type ,temp) ,(if (consp low) (car low) low)))) + ,@(if high `((,(if (consp high) '< '<=) (the ,type ,temp) ,(if (consp high) (car high) high)))))) + `(typep ,thing ',type))))))) + (t `(numeric-%%typep ,thing ,ctype)))) + (array-ctype + (or + (let* ((typecode (array-ctype-typecode ctype)) + (dims (array-ctype-dimensions ctype))) + (cond ((and typecode (consp dims) (null (cdr dims))) + (case (array-ctype-complexp ctype) + ((nil) + (if (eq (car dims) '*) + `(eql (typecode ,thing) ,typecode) + (let* ((temp (gensym))) + `(let* ((,temp ,thing)) + (and (eql (typecode ,temp) ,typecode) + (eq (uvsize ,temp) ,(car dims))))))) + ((* :maybe) + (let* ((temp (gensym)) + (tempcode (gensym))) + `(let* ((,temp ,thing) + (,tempcode (typecode ,temp))) + (or (and (eql ,tempcode ,typecode) + ,@(unless (eq (car dims) '*) + `((eq (uvsize ,temp) ,(car dims))))) + (and (eql ,tempcode target::subtag-vectorH) + (eql (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,temp target::arrayH.flags-cell))) ,typecode) + ,@(unless (eq (car dims) '*) + `((eq (%svref ,temp target::vectorH.logsize-cell) ,(car dims))))))))))))) + `(array-%%typep ,thing ,ctype)))))) + + + (defun optimize-typep (thing type env) ;; returns a new form, or nil if it can't optimize - (cond ((symbolp type) - (let ((typep (type-predicate type))) - (cond ((and typep - (symbolp typep)) - `(,typep ,thing)) - ((%deftype-expander type) - ;; recurse here, rather than returning the - ;; partially-expanded form mostly since it doesn't - ;; seem to further optimize the result otherwise - (let ((expanded-type (type-expand type))) - (or (optimize-typep thing expanded-type env) - ;; at least do the first expansion - `(typep ,thing ',expanded-type)))) - ((structure-class-p type env) - `(structure-typep ,thing ',type)) - ((find-class type nil env) - `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t)))) - ((info-type-builtin type) ; bootstrap troubles here? - `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) - (t nil)))) - ((consp type) - (cond - ((info-type-builtin type) ; byte types - `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) - (t - (case (%car type) - (satisfies `(funcall ',(cadr type) ,thing)) - (eql `(eql ,thing ',(cadr type))) - (member `(not (null (member ,thing ',(%cdr type))))) - (not `(not (typep ,thing ',(cadr type)))) - ((or and) - (let ((thing-sym (gensym))) - `(let ((,thing-sym ,thing)) - (,(%car type) - ,@(mapcar #'(lambda (type-spec) - (or (optimize-typep thing-sym type-spec env) - `(typep ,thing-sym ',type-spec))) - (%cdr type)))))) - ((signed-byte unsigned-byte integer mod) ; more byte types - `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) - (t nil))))) - (t nil))) + (let* ((ctype (ignore-errors (specifier-type type)))) + (when (and ctype (not (typep ctype 'unknown-ctype))) + (let* ((type (type-specifier ctype)) + (predicate (if (typep type 'symbol) (type-predicate type)))) + (if (and predicate (symbolp predicate)) + `(,predicate ,thing) + (or (optimize-ctypep thing ctype) + (cond ((symbolp type) + (cond ((%deftype-expander type) + ;; recurse here, rather than returning the + ;; partially-expanded form mostly since it doesn't + ;; seem to further optimize the result otherwise + (let ((expanded-type (type-expand type))) + (or (optimize-typep thing expanded-type env) + ;; at least do the first expansion + `(typep ,thing ',expanded-type)))) + ((structure-class-p type env) + `(structure-typep ,thing ',type)) + ((find-class type nil env) + `(class-cell-typep ,thing (load-time-value (find-class-cell ',type t)))) + ((info-type-builtin type) ; bootstrap troubles here? + `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) + (t nil))) + ((consp type) + (cond + ((info-type-builtin type) ; byte types + `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) + (t + (case (%car type) + (satisfies `(funcall ',(cadr type) ,thing)) + (eql `(eql ,thing ',(cadr type))) + (member `(not (null (member ,thing ',(%cdr type))))) + (not `(not (typep ,thing ',(cadr type)))) + ((or and) + (let ((thing-sym (gensym))) + `(let ((,thing-sym ,thing)) + (,(%car type) + ,@(mapcar #'(lambda (type-spec) + (or (optimize-typep thing-sym type-spec env) + `(typep ,thing-sym ',type-spec))) + (%cdr type)))))) + ((signed-byte unsigned-byte integer mod) ; more byte types + `(builtin-typep ,thing (load-time-value (find-builtin-cell ',type)))) + (t nil))))) + (t nil)))))))) (define-compiler-macro typep (&whole call &environment env thing type &optional e) (declare (ignore e)) (if (quoted-form-p type) - (or (optimize-typep thing (%cadr type) env) - call) - call)) + (if (constantp thing) + (typep (if (quoted-form-p thing) (%cadr thing) thing) (%cadr type)) + (or (optimize-typep thing (%cadr type) env) + call)) + (if (eq type t) + `(progn ,thing t) + call))) (define-compiler-macro true (&rest args) @@ -1670,4 +1851,19 @@ `(simple-base-string-p ,thing)) +(define-compiler-macro stringp (thing) + `(base-string-p ,thing)) + +(define-compiler-macro base-string-p (thing) + (let* ((gthing (gensym)) + (gtype (gensym))) + `(let* ((,gthing ,thing) + (,gtype (typecode ,thing))) + (declare (type (unsigned-byte 8) ,gtype)) + (if (= ,gtype ,(nx-lookup-target-uvector-subtag :vector-header)) + (= (the (unsigned-byte 8) + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref ,gthing target::arrayH.flags-cell)))) + ,(nx-lookup-target-uvector-subtag :simple-string)) + (= ,gtype ,(nx-lookup-target-uvector-subtag :simple-string)))))) + (defsetf %misc-ref %misc-set) @@ -1685,6 +1881,7 @@ `(let* ((,typecode (typecode ,thing))) (declare (fixnum ,typecode)) - (or (= ,typecode ,fixnum-tag) - (= ,typecode ,bignum-tag))))) + (if (= ,typecode ,fixnum-tag) + t + (= ,typecode ,bignum-tag))))) (define-compiler-macro %composite-pointer-ref (size pointer offset) @@ -1814,5 +2011,23 @@ `(float ,thing 0.0d0) call))) - + +(define-compiler-macro equal (&whole call x y &environment env) + (if (or (equal-iff-eql-p x env) + (equal-iff-eql-p y env)) + `(eql ,x ,y) + call)) + +(define-compiler-macro instance-slots (&whole w instance) + (if (and (constantp instance) + (eql (typecode instance) (nx-lookup-target-uvector-subtag :instance))) + `(instance.slots ,instance) + w)) + +(define-compiler-macro unsigned-byte-p (x) + (if (typep (nx-unquote x) 'unsigned-byte) + t + (let* ((val (gensym))) + `(let* ((,val ,x)) + (and (integerp ,val) (not (< ,val 0))))))) (provide "OPTIMIZERS") Index: /branches/event-ide/ccl/compiler/vinsn.lisp =================================================================== --- /branches/event-ide/ccl/compiler/vinsn.lisp (revision 8261) +++ /branches/event-ide/ccl/compiler/vinsn.lisp (revision 8262) @@ -578,19 +578,19 @@ (insert-dll-node-after lab current)))) (:branch - (unless (eq prevtype :jump) - (let* ((lab - (if (eq prevtype :label) - (dll-node-succ current) - (aref *backend-labels* (backend-get-next-label)))) - (jump (select-vinsn "JUMP" *backend-vinsns* (list lab)))) - (unless (eq prevtype :label) - (insert-dll-node-after lab current)) - (insert-dll-node-after jump current)))) + (unless (eq prevtype :jump) + (let* ((lab + (if (eq prevtype :label) + (dll-node-succ current) + (aref *backend-labels* (backend-get-next-label)))) + (jump (select-vinsn "JUMP" *backend-vinsns* (list lab)))) + (unless (eq prevtype :label) + (insert-dll-node-after lab current)) + (insert-dll-node-after jump current)))) ((nil) (if (eq prevtype :label) (let* ((lab (dll-node-succ current))) (when (vinsn-label-p lab) - (insert-dll-node-after - (select-vinsn "JUMP" *backend-vinsns* (list lab)) + (insert-dll-node-after + (select-vinsn "JUMP" *backend-vinsns* (list lab)) current)))))))) @@ -647,4 +647,22 @@ (dll-node-pred (svref (vinsn-variable-parts v) 0))) +(defun replace-label-refs (vinsn old-label new-label) + (let ((vp (vinsn-variable-parts vinsn))) + (dotimes (i (length vp)) + (when (eq (svref vp i) old-label) + (setf (svref vp i) new-label))))) + +;;; Try to remove jumps/branches to jumps. +(defun maximize-jumps (header) + (do* ((prev nil next) + (next (dll-header-first header) (dll-node-succ next))) + ((eq next header)) + (when (and (vinsn-attribute-p next :jump) + (vinsn-label-p prev)) + (let* ((target (svref (vinsn-variable-parts next) 0))) + (unless (eq target prev) + (dolist (ref (vinsn-label-refs prev) (setf (vinsn-label-refs prev) nil)) + (replace-label-refs ref prev target) + (push ref (vinsn-label-refs target)))))))) (defun optimize-vinsns (header) @@ -669,4 +687,5 @@ (setq repeat t) (return))))) + (maximize-jumps header) (delete-unreferenced-labels labels) (normalize-vinsns header) Index: /branches/event-ide/ccl/level-0/PPC/ppc-misc.lisp =================================================================== --- /branches/event-ide/ccl/level-0/PPC/ppc-misc.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/PPC/ppc-misc.lisp (revision 8262) @@ -551,55 +551,5 @@ (blr)) -;;; Return true iff we were able to increment a non-negative -;;; lock._value -(defppclapfunction %try-read-lock-rwlock ((lock arg_z)) - (check-nargs 1) - (li imm1 target::lock._value) - @try - (lrarx imm0 lock imm1) - (cmpri imm0 0) - (blt @fail) ; locked for writing - (addi imm0 imm0 '1) - (strcx. imm0 lock imm1) - (bne @try) ; lost reservation, try again - (isync) - (blr) ; return the lock -@fail - (li imm0 target::reservation-discharge) - (strcx. rzero rzero imm0) - (li arg_z nil) - (blr)) - - - -(defppclapfunction unlock-rwlock ((lock arg_z)) - (ldr imm2 target::lock._value lock) - (cmpri imm2 0) - (li imm1 target::lock._value) - (ble @unlock-write) - @unlock-read - (lrarx imm0 lock imm1) - (subi imm0 imm0 '1) - (strcx. imm0 lock imm1) - (bne @unlock-read) - (isync) - (blr) - @unlock-write - ;;; If we aren't the writer, return NIL. - ;;; If we are and the value's about to go to 0, clear the writer field. - (ldr imm0 target::lock.writer lock) - (cmpr imm0 target::rcontext) - (ldrx imm0 lock imm1) - (cmpri cr1 imm0 '-1) - (addi imm0 imm0 '1) - (bne @fail) - (bne cr1 @noclear) - (str rzero target::lock.writer lock) - @noclear - (str imm0 target::lock._value lock) - (blr) - @fail - (li arg_z nil) - (blr)) + (defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) @@ -1022,4 +972,29 @@ (blr)) +(defppclapfunction %check-deferred-gc () + (ldr imm0 target::tcr.flags target::rcontext) + (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift))) + (li arg_z nil) + (bgelr) + (uuo_interr arch::error-propagate-suspend rzero) + (li arg_z t) + (blr)) + +(defppclapfunction %atomic-pop-static-cons () + (li imm0 (+ target::nil-value (target::kernel-global static-conses))) + @again + (lrarx arg_z rzero imm0) + (cmpri arg_z target::nil-value) + (beq @lose) + (%cdr arg_y arg_z) + (strcx. arg_y rzero imm0) + (isync) + (bne @again) + (blr) + @lose + (li imm0 target::reservation-discharge) + (strcx. rzero rzero imm0) + (blr)) + ; end of ppc-misc.lisp Index: /branches/event-ide/ccl/level-0/PPC/ppc-symbol.lisp =================================================================== --- /branches/event-ide/ccl/level-0/PPC/ppc-symbol.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/PPC/ppc-symbol.lisp (revision 8262) @@ -152,2 +152,27 @@ (srri arg_z accum (- 5 target::fixnumshift)) (blr))) + +(defppclapfunction %string-hash ((start arg_x) (str arg_y) (len arg_z)) + (let ((nextw imm1) + (accum imm0) + (offset imm2)) + (cmpwi cr0 len 0) + #+32-bit-target + (la offset target::misc-data-offset start) + #+64-bit-target + (progn + (srwi offset start 1) + (la offset target::misc-data-offset offset)) + (li accum 0) + (beqlr- cr0) + @loop + (cmpri cr1 len '1) + (subi len len '1) + (lwzx nextw str offset) + (addi offset offset 4) + (rotlwi accum accum 5) + (xor accum accum nextw) + (bne cr1 @loop) + (slri accum accum 5) + (srri arg_z accum (- 5 target::fixnumshift)) + (blr))) Index: /branches/event-ide/ccl/level-0/PPC/ppc-utils.lisp =================================================================== --- /branches/event-ide/ccl/level-0/PPC/ppc-utils.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/PPC/ppc-utils.lisp (revision 8262) @@ -576,5 +576,13 @@ - +(defppclapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (check-nargs 0) + (li imm0 arch::gc-trap-function-freeze) + (trlgei allocptr 0) + #+64-bit-target + (ba .SPmakeu64) + #+32-bit-target + (ba .SPmakeu32)) Index: /branches/event-ide/ccl/level-0/X86/x86-array.lisp =================================================================== --- /branches/event-ide/ccl/level-0/X86/x86-array.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/X86/x86-array.lisp (revision 8262) @@ -26,11 +26,166 @@ - - -;; rewrite in LAP someday (soon). +#+x8664-target +(progn +;;; None of the stores in here can be intergenerational; the vector +;;; is known to be younger than the initial value +(defx86lapfunction %init-gvector ((len arg_x) (value arg_y) (vector arg_z)) + (jmp @test) + @loop + (movq (% value) (@ x8664::misc-data-offset (% vector) (% len))) + @test + (subq ($ x8664::fixnumone) (% len)) + (jns @loop) + (single-value-return)) + +;;; "val" is either a fixnum or a uvector with 64-bits of data +;;; (small bignum, DOUBLE-FLOAT). +(defx86lapfunction %%init-ivector64 ((len arg_x) (value arg_y) (vector arg_z)) + (unbox-fixnum value imm0) + (testb ($ x8664::fixnummask) (%b value)) + (je @test) + (movq (@ x8664::misc-data-offset (% value)) (% imm0)) + (jmp @test) + @loop + (movq (% imm0) (@ x8664::misc-data-offset (% vector) (% len))) + @test + (subq ($ x8664::fixnumone) (% len)) + (jns @loop) + (single-value-return)) + +(defun %init-ivector64 (typecode len val uvector) + (declare (type (mod 256) typecode)) + (%%init-ivector64 len + (case typecode + (#.x8664::subtag-fixnum-vector + (require-type val 'fixnum)) + (#.x8664::subtag-double-float-vector + (if (typep val 'double-float) + val + (require-type val 'double-float))) + (#.x8664::subtag-s64-vector + (require-type val '(signed-byte 64))) + (#.x8664::subtag-u64-vector + (require-type val '(unsigned-byte 64))) + (t (report-bad-arg uvector + '(or (simple-array fixnum (*)) + (simple-array double-float (*)) + (simple-array (signed-byte 64) (*)) + (simple-array (unsigned-byte 64) (*)))))) + uvector)) + + +(eval-when (:compile-toplevel :execute) + (declaim (inline %init-ivector-u32))) + +(defun %init-ivector-u32 (len u32val uvector) + (declare (type index len) + (type (unsigned-byte 32) u32val) + (type (simple-array (unsigned-byte 32) (*)) uvector) + (optimize (speed 3) (safety 0))) + (dotimes (i len uvector) + (setf (aref uvector i) u32val))) + +(eval-when (:compile-toplevel :execute) + (declaim (inline %init-ivector-u16))) + +(defun %init-ivector-u16 (len val uvector) + (declare (type index len) + (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 16) (*)) uvector) + (optimize (speed 3) (safety 0))) + (dotimes (i len uvector) + (setf (aref uvector i) val))) + + + +(defun %init-ivector32 (typecode len val uvector) + (declare (type (unsigned-byte 32) typecode) + (type index len)) + (let* ((u32val (case typecode + (#.x8664::subtag-s32-vector + (logand (the (signed-byte 32) + (require-type val '(signed-byte 32))) + #xffffffff)) + (#.x8664::subtag-single-float-vector + (single-float-bits (require-type val 'single-float))) + (#.x8664::subtag-simple-base-string + (char-code val)) + (t + (require-type val '(unsigned-byte 32)))))) + (declare (type (unsigned-byte 32) u32val)) + (%init-ivector-u32 len u32val uvector))) + +(defun %init-misc (val uvector) + (let* ((len (uvsize uvector)) + (typecode (typecode uvector)) + (fulltag (logand x8664::fulltagmask typecode))) + (declare (type index len) + (type (unsigned-byte 8) typecode) + (type (mod 16) fulltag)) + (if (or (= fulltag x8664::fulltag-nodeheader-0) + (= fulltag x8664::fulltag-nodeheader-1)) + (%init-gvector len val uvector) + (if (= fulltag x8664::ivector-class-64-bit) + (%init-ivector64 typecode len val uvector) + (if (= fulltag x8664::ivector-class-32-bit) + (%init-ivector32 typecode len val uvector) + ;; Value must be a fixnum, 1, 8, 16 bits + (case typecode + (#.x8664::subtag-u16-vector + (%init-ivector-u16 len + (require-type val '(unsigned-byte 16)) + uvector)) + (#.x8664::subtag-s16-vector + (%init-ivector-u16 len + (logand (the (signed-byte 16) + (require-type val '(unsigned-byte 16))) + #xffff) + uvector)) + (#.x8664::subtag-u8-vector + (let* ((v0 (require-type val '(unsigned-byte 8))) + (l0 (ash (the fixnum (1+ len)) -1))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%init-ivector-u16 l0 + (logior (the (unsigned-byte 16) (ash v0 8)) + v0) + uvector))) + (#.x8664::subtag-s8-vector + (let* ((v0 (logand #xff + (the (signed-byte 8) + (require-type val '(signed-byte 8))))) + (l0 (ash (the fixnum (1+ len)) -1))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%init-ivector-u16 l0 + (logior (the (unsigned-byte 16) (ash v0 8)) + v0) + uvector))) + (#.x8664::subtag-bit-vector + (if (eql 0 val) + uvector + (let* ((v0 (case val + (1 -1) + (t (report-bad-arg val 'bit)))) + (l0 (ash (the fixnum (+ len 63)) -6))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%%init-ivector64 l0 v0 uvector)))) + (t (report-bad-arg uvector + '(or simple-bit-vector + (simple-array (signed-byte 8) (*)) + (simple-array (unsigned-byte 8) (*)) + (simple-array (signed-byte 16) (*)) + (simple-array (unsigned-byte 16) (*))))))))))) + + +) + +#-x8664-target (defun %init-misc (val uvector) (dotimes (i (uvsize uvector) uvector) (setf (uvref uvector i) val))) - + ;;; Make a new vector of size newsize whose subtag matches that of oldv-arg. Index: /branches/event-ide/ccl/level-0/X86/x86-clos.lisp =================================================================== --- /branches/event-ide/ccl/level-0/X86/x86-clos.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/X86/x86-clos.lisp (revision 8262) @@ -35,5 +35,4 @@ (shrq ($ x8664::word-shift) (% imm1)) (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) - (shlq ($ x8664::word-shift) (% imm1)) @have-table-index (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) @@ -166,4 +165,8 @@ (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) (movq (@ (% rsp)) (% ra0)) (save-frame-variable-arg-count) @@ -191,4 +194,8 @@ (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) (check-nargs 1) (movq (@ 'dispatch-table (% fn)) (% arg_y)) @@ -199,4 +206,8 @@ (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) (check-nargs 2) (movq (@ 'dispatch-table (% fn)) (% arg_x)) Index: /branches/event-ide/ccl/level-0/X86/x86-misc.lisp =================================================================== --- /branches/event-ide/ccl/level-0/X86/x86-misc.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/X86/x86-misc.lisp (revision 8262) @@ -393,46 +393,7 @@ ;;; Return true iff we were able to increment a non-negative ;;; lock._value -(defx86lapfunction %try-read-lock-rwlock ((lock arg_z)) - (check-nargs 1) - @try - (movq (@ x8664::lock._value (% lock)) (% rax)) - (movq (% rax) (% imm1)) - (addq ($ '1) (% imm1)) - (jle @fail) - (lock) - (cmpxchgq (% imm1) (@ x8664::lock._value (% lock))) - (jne @try) - (single-value-return) ; return the lock -@fail - (movl ($ x8664::nil-value) (%l arg_z)) - (single-value-return)) - - - -(defx86lapfunction unlock-rwlock ((lock arg_z)) - (cmpq ($ 0) (@ x8664::lock._value (% lock))) - (jle @unlock-write) - @unlock-read - (movq (@ x8664::lock._value (% lock)) (% rax)) - (lea (@ '-1 (% imm0)) (% imm1)) - (lock) - (cmpxchgq (% imm1) (@ x8664::lock._value (% lock))) - (jne @unlock-read) - (single-value-return) - @unlock-write - ;;; If we aren't the writer, return NIL. - ;;; If we are and the value's about to go to 0, clear the writer field. - (movq (@ x8664::lock.writer (% lock)) (% imm0)) - (cmpq (% imm0) (@ (% :rcontext) x8664::tcr.linear)) - (jne @fail) - (cmpq ($ '-1) (@ x8664::lock._value (% lock))) - (jne @still-owner) - (movsd (% fpzero) (@ x8664::lock.writer (% lock))) - @still-owner - (addq ($ '1) (@ x8664::lock._value (% lock))) - (single-value-return) - @fail - (movl ($ x8664::nil-value) (%l arg_z)) - (single-value-return)) + + + (defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) @@ -536,4 +497,14 @@ (single-value-return))) +(defx86lapfunction xchgl ((newval arg_y) (ptr arg_z)) + (unbox-fixnum newval imm0) + (macptr-ptr ptr imm1) + (lock) ; implicit ? + (xchgl (% imm0.l) (@ (% imm1))) + (box-fixnum imm0 arg_z) + (single-value-return)) + + + (defx86lapfunction %macptr->dead-macptr ((macptr arg_z)) @@ -542,110 +513,4 @@ (single-value-return)) -#+are-you-kidding -(defx86lapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0) - (parent arg_x) (function arg_y) (arglist arg_z)) - (check-nargs 7) - - ; Throw through catch-count catch frames - (lwz imm0 12 vsp) ; catch-count - (vpush parent) - (vpush function) - (vpush arglist) - (bla .SPnthrowvalues) - - ; Pop tsp-count TSP frames - (lwz tsp-count 16 vsp) - (cmpi cr0 tsp-count 0) - (b @test) -@loop - (subi tsp-count tsp-count '1) - (cmpi cr0 tsp-count 0) - (lwz tsp 0 tsp) -@test - (bne cr0 @loop) - - ; Pop dynamic bindings until we get to db-link - (lwz imm0 12 vsp) ; db-link - (lwz imm1 x8664::tcr.db-link :rcontext) - (cmp cr0 imm0 imm1) - (beq cr0 @restore-regs) ; .SPunbind-to expects there to be something to do - (bla .SPunbind-to) - -@restore-regs - ; restore the saved registers from srv - (lwz srv 20 vsp) -@get0 - (svref imm0 1 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get1) - (lwz save0 0 imm0) -@get1 - (svref imm0 2 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get2) - (lwz save1 0 imm0) -@get2 - (svref imm0 3 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get3) - (lwz save2 0 imm0) -@get3 - (svref imm0 4 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get4) - (lwz save3 0 imm0) -@get4 - (svref imm0 5 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get5) - (lwz save4 0 imm0) -@get5 - (svref imm0 6 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get6) - (lwz save5 0 imm0) -@get6 - (svref imm0 7 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @get7) - (lwz save6 0 imm0) -@get7 - (svref imm0 8 srv) - (cmpwi cr0 imm0 x8664::nil-value) - (beq @got) - (lwz save7 0 imm0) -@got - - (vpop arg_z) ; arglist - (vpop temp0) ; function - (vpop parent) ; parent - (extract-lisptag imm0 parent) - (cmpi cr0 imm0 x8664::tag-fixnum) - (if (:cr0 :ne) - ; Parent is a fake-stack-frame. Make it real - (progn - (svref sp %fake-stack-frame.sp parent) - (stwu sp (- x8664::lisp-frame.size) sp) - (svref fn %fake-stack-frame.fn parent) - (stw fn x8664::lisp-frame.savefn sp) - (svref temp1 %fake-stack-frame.vsp parent) - (stw temp1 x8664::lisp-frame.savevsp sp) - (svref temp1 %fake-stack-frame.lr parent) - (extract-lisptag imm0 temp1) - (cmpi cr0 imm0 x8664::tag-fixnum) - (if (:cr0 :ne) - ;; must be a macptr encoding the actual link register - (macptr-ptr loc-pc temp1) - ;; Fixnum is offset from start of function vector - (progn - (svref temp2 0 fn) ; function vector - (unbox-fixnum temp1 temp1) - (add loc-pc temp2 temp1))) - (stw loc-pc x8664::lisp-frame.savelr sp)) - ;; Parent is a real stack frame - (mr sp parent)) - (set-nargs 0) - (bla .SPspreadargz) - (ba .SPtfuncallgen)) @@ -750,4 +615,187 @@ ;;; it still called ? +(defx86lapfunction %check-deferred-gc () + (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (@ (% :rcontext) x8664::tcr.flags)) + (movl ($ x8664::nil-value) (% arg_z.l)) + (jae @done) + (ud2a) + (:byte 3) + (movl ($ x8664::t-value) (% arg_z.l)) + @done + (single-value-return)) + +(defx86lapfunction %get-spin-lock ((p arg_z)) + (check-nargs 1) + (save-simple-frame) + @again + (macptr-ptr arg_z imm1) + (movq (@ '*spin-lock-tries* (% fn)) (% temp0)) + (movq (@ '*spin-lock-timeouts* (% fn)) (% temp1)) + (movq (@ target::symbol.vcell (% temp0)) (% temp0)) + (movq (@ (% :rcontext) x8664::tcr.linear) (% arg_y)) + @try-swap + (xorq (% rax) (% rax)) + (lock) + (cmpxchgq (% arg_y) (@ (% imm1))) + (je @done) + @spin + (pause) + (cmpq ($ 0) (@ (% imm1))) + (je @try-swap) + (subq ($ '1) (% temp0)) + (jne @spin) + @wait + (addq ($ x8664::fixnumone) (@ x8664::symbol.vcell (% temp1))) + (pushq (% arg_z)) + (call-symbol yield 0) + (popq (% arg_z)) + (jmp @again) + @done + (restore-simple-frame) + (single-value-return)) + +;;; This is a prototype; it can't easily keep its arguments on the stack, +;;; or in registers, because its job involves unwinding the stack and +;;; restoring registers. Its parameters are thus kept in constants, +;;; and this protoype is cloned (with the right parameters). + +(defx86lapfunction %%apply-in-frame-proto () + (:fixed-constants (target-frame target-catch target-db-link target-xcf target-tsp target-foreign-sp save0-offset save1-offset save2-offset save3-offset function args)) + (check-nargs 0) + ;;(uuo-error-debug-trap) + (movq (@ 'target-catch (% fn)) (% temp0)) + (xorl (%l imm0) (%l imm0)) + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (movq (@ (% :rcontext) target::tcr.catch-top) (% arg_z)) + (jz @did-catch) + @find-catch + (testq (% arg_z) (% arg_z)) + (jz @did-catch) ; never found target catch + (addq ($ '1) (% imm0)) + (cmpq (% temp0) (% arg_z)) + (je @found-catch) + (movq (@ target::catch-frame.link (% arg_z)) (% arg_z)) + (jmp @find-catch) + @found-catch + (set-nargs 0) ; redundant, but ... + (lea (@ (:^ @back-from-nthrow) (% fn)) (% ra0)) + (:talign 4) + (jmp-subprim .SPnthrowvalues) + @back-from-nthrow + (recover-fn-from-rip) + @did-catch + ;; Restore special bindings + (movq (@ 'target-db-link (% fn)) (% imm0)) + (cmpb ($ x8664::fulltag-nil) (%b imm0)) + (jz @no-unbind) + (call-subprim .SPunbind-to) + @no-unbind + ;; If there's at least one exception frame between the target + ;; frame and the last catch (or the point of departure), restore + ;; the NVRs and foreign sp from the oldest such frame + (movq (@ 'target-xcf (% fn)) (% arg_z)) + (cmpb ($ x8664::fulltag-nil) (%b arg_z)) + (jz @no-xcf) + (movq (@ target::xcf.xp (% arg_z)) (% arg_y)) + ;; arg_y points to a "portable" ucontext. Find the platform-specifc + ;; "gpr vector" in the uc_mcontext, load the NVRs and stack/frame + ;; pointer from there. + #+linuxx8664-target + (progn + (addq ($ gp-regs-offset) (% arg_y)) + (movq (@ (* #$REG_R15 8) (% arg_y)) (% r15)) + (movq (@ (* #$REG_R14 8) (% arg_y)) (% r14)) + (movq (@ (* #$REG_R12 8) (% arg_y)) (% r12)) + (movq (@ (* #$REG_R11 8) (% arg_y)) (% r11)) + (movq (@ (* #$REG_RBP 8) (% arg_y)) (% rbp)) + (movq (@ (* #$REG_RSP 8) (% arg_y)) (% rsp))) + #+freebsdx8664-target + (progn + ;; If you think that this is ugly, just wait until you see the Darwin + ;; version. + (addq ($ gp-regs-offset) (% arg_y)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r15)) -3) (% arg_y)) (% r15)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r14)) -3) (% arg_y)) (% r14)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r12)) -3) (% arg_y)) (% r12)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r11)) -3) (% arg_y)) (% r11)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rbp)) -3) (% arg_y)) (% rbp)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rsp)) -3) (% arg_y)) (% rsp))) + #+darwinx8664-target + (progn + ;; Yes, this is ugly. + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_ucontext)) :uc_mcontext)) -3) (% arg_y)) (% arg_y)) + (addq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_mcontext64)) :__ss)) -3)) (% arg_y)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r15)) -3) (% arg_y)) (% r15)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r14)) -3) (% arg_y)) (% r14)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r12)) -3) (% arg_y)) (% r12)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r11)) -3) (% arg_y)) (% r11)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rbp)) -3) (% arg_y)) (% rbp)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rsp)) -3) (% arg_y)) (% rsp))) + ;; This is our best (possibly only) chance to get + ;; the foreign sp right. + (movq (@ target::xcf.prev-xframe (% arg_z)) (% temp0)) + (movq (@ target::xcf.foreign-sp (% arg_z)) (% imm0)) + (movq (% temp0) (@ (% :rcontext) target::tcr.xframe)) + (movq (% imm0) (@ (% :rcontext) target::tcr.foreign-sp)) + ;; All done processing the xcf. NVRs may have been + ;; saved between the last catch/last xcf and the + ;; target frame. The save-n-offset parameter/constants + ;; are either 0 or negative offsets from the target frame + ;; of the stack location where the corresponding GPR + ;; was saved. + @no-xcf + (movq (@ 'target-tsp (% fn)) (% imm0)) + (cmpb ($ x8664::fulltag-nil) (%b imm0)) + (movq (@ 'target-foreign-sp (% fn)) (% temp0)) + (je @no-tsp) + (movq (% imm0) (@ (% :rcontext) target::tcr.save-tsp)) + (movq (% imm0) (@ (% :rcontext) target::tcr.next-tsp)) + @no-tsp + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (je @no-sp) + (movq (% temp0) (@ (% :rcontext) target::tcr.foreign-sp)) + @no-sp + (movq (@ 'target-frame (% fn)) (% rbp)) + (movq (@ 'save0-offset (% fn)) (% arg_x)) + (movq (@ 'save1-offset (% fn)) (% arg_y)) + (movq (@ 'save2-offset (% fn)) (% arg_z)) + (movq (@ 'save3-offset (% fn)) (% temp0)) + (testq (% arg_x) (% arg_x)) + (cmovneq (@ (% rbp) (% arg_x)) (% save0)) + (testq (% arg_y) (% arg_y)) + (cmovneq (@ (% rbp) (% arg_x)) (% save1)) + (testq (% arg_z) (% arg_z)) + (cmovneq (@ (% rbp) (% arg_x)) (% save2)) + (testq (% temp0) (% temp0)) + (cmovneq (@ (% rbp) (% arg_x)) (% save3)) + (leave) + (pop (% temp0)) ; return address, not used by subprim + (set-nargs 0) + (movq (@ 'args (% fn)) (% arg_z)) + (lea (@ (:^ @back-from-spread) (% fn)) (% ra0)) + (:talign 4) + (jmp-subprim .SPspreadargz) + @back-from-spread + (recover-fn-from-rip) ; .SPspreadargz preserves %fn, but ... + (push (% temp0)) ; return address + (jmp (@ 'function (% fn)))) + + +(defx86lapfunction %atomic-pop-static-cons () + @again + (movq (@ (+ x8664::nil-value (x8664::kernel-global static-conses))) (% rax)) + (testq ($ x8664::nil-value) (% rax)) + (jz @lose) + (%cdr rax temp0) + (lock) + (cmpxchgq (% temp0) (@ (+ x8664::nil-value (x8664::kernel-global static-conses)))) + (jnz @again) + @lose + (movq (% rax) (% arg_z)) + (single-value-return)) + + + + ;;; end of x86-misc.lisp Index: /branches/event-ide/ccl/level-0/X86/x86-numbers.lisp =================================================================== --- /branches/event-ide/ccl/level-0/X86/x86-numbers.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/X86/x86-numbers.lisp (revision 8262) @@ -113,9 +113,11 @@ ;;; the word below the stack pointer (defx86lapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (save-simple-frame) (unbox-fixnum divisor imm0) - (movq (% imm0) (@ -8 (% rsp))) + (movq (% imm0) (% imm2)) (unbox-fixnum dividend imm0) (cqto) ; imm1 := sign_extend(imm0) - (idivq (@ -8 (% rsp))) + (idivq (% imm2)) + (pop (% rbp)) (movq (% rsp) (% temp0)) (box-fixnum imm1 arg_y) Index: /branches/event-ide/ccl/level-0/X86/x86-symbol.lisp =================================================================== --- /branches/event-ide/ccl/level-0/X86/x86-symbol.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/X86/x86-symbol.lisp (revision 8262) @@ -142,2 +142,21 @@ @done (single-value-return))) + +(defx86lapfunction %string-hash ((start arg_x) (str arg_y) (len arg_z)) + (let ((accum imm0) + (offset imm1)) + (unbox-fixnum start offset) + (xorq (% accum) (% accum)) + (cmpq ($ 0) (% len)) + (jz.pn @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8664::misc-data-offset (% str) (% offset) 4) (%l accum)) + (addq ($ 1) (% offset)) + (subq ($ '1) (% len)) + (jnz @loop8) + (shlq ($ 5) (% accum)) + (shrq ($ (- 5 x8664::fixnumshift)) (% accum)) + (movq (% accum) (% arg_z)) + @done + (single-value-return))) Index: /branches/event-ide/ccl/level-0/X86/x86-utils.lisp =================================================================== --- /branches/event-ide/ccl/level-0/X86/x86-utils.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/X86/x86-utils.lisp (revision 8262) @@ -443,4 +443,12 @@ (single-value-return)) +(defx86lapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (movq ($ arch::gc-trap-function-freeze) (% imm0)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu64)) + + + Index: /branches/event-ide/ccl/level-0/l0-aprims.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-aprims.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-aprims.lisp (revision 8262) @@ -22,5 +22,5 @@ ;;; This weak list is used to track semaphores as well as locks. (defvar %system-locks% nil) -(setf %system-locks% (%cons-population nil)) + (defun record-system-lock (l) @@ -71,6 +71,6 @@ (when nul-terminated (setf (%get-byte pointer n) 0))) - nil) - (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))) + nil)) + (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)) (defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t)) @@ -123,5 +123,10 @@ :address)))) - +(defun %make-rwlock-ptr () + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeRwLock) + (ff-call (%kernel-import target::kernel-import-rwlock-new) + :address)))) (defun make-recursive-lock () @@ -131,5 +136,5 @@ "Create and return a lock object, which can be used for synchronization between threads." - (gvector :lock (%make-recursive-lock-ptr) 'recursive-lock 0 name)) + (gvector :lock (%make-recursive-lock-ptr) 'recursive-lock 0 name nil nil)) (defun lock-name (lock) @@ -142,11 +147,40 @@ (report-bad-arg r 'recursive-lock))) - +(defun recursive-lock-whostate (r) + (if (and (eq target::subtag-lock (typecode r)) + (eq (%svref r target::lock.kind-cell) 'recursive-lock)) + (or (%svref r target::lock.whostate-cell) + (setf (%svref r target::lock.whostate-cell) + (format nil "Lock ~s wait" r))) + (report-bad-arg r 'recursive-lock))) + + +(defun read-write-lock-ptr (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (%svref rw target::lock._value-cell) + (report-bad-arg rw 'read-write-lock))) (defun make-read-write-lock () "Create and return a read-write lock, which can be used for synchronization between threads." - (gvector :lock 0 'read-write-lock 0 nil)) - + (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil nil nil)) + +(defun rwlock-read-whostate (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (or (%svref rw target::lock.whostate-cell) + (setf (%svref rw target::lock.whostate-cell) + (format nil "Read lock ~s wait" rw))) + (report-bad-arg rw 'read-write-lock))) + +(defun rwlock-write-whostate (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (or (%svref rw target::lock.whostate-2-cell) + (setf (%svref rw target::lock.whostate-2-cell) + (format nil "Read lock ~s wait" rw))) + (report-bad-arg rw 'read-write-lock))) + (defun %make-semaphore-ptr () @@ -171,3 +205,13 @@ (setf (type-predicate 'semaphore) 'semaphorep) +(defun make-list (size &key initial-element) + "Constructs a list with size elements each set to value" + (unless (and (typep size 'fixnum) + (>= (the fixnum size) 0)) + (report-bad-arg size '(and fixnum unsigned-byte))) + (locally (declare (fixnum size)) + (do* ((result '() (cons initial-element result))) + ((zerop size) result) + (decf size)))) + ; end Index: /branches/event-ide/ccl/level-0/l0-bignum64.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-bignum64.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-bignum64.lisp (revision 8262) @@ -2068,4 +2068,21 @@ +(defun %bignum-random (number state) + (let* ((ndigits (%bignum-length number)) + (sign-index (1- ndigits))) + (declare (fixnum ndigits sign-index)) + (with-bignum-buffers ((bignum ndigits)) + (dotimes (i sign-index) + (setf (bignum-ref bignum i) (%next-random-seed state))) + (setf (bignum-ref bignum sign-index) + (logand #x7fffffff (the (unsigned-byte 32) + (%next-random-seed state)))) + (let* ((result (mod bignum number))) + (if (eq result bignum) + (copy-uvector bignum) + result))))) + + + (defun logbitp (index integer) "Predicate returns T if bit index of integer is a 1." Index: /branches/event-ide/ccl/level-0/l0-hash.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-hash.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-hash.lisp (revision 8262) @@ -160,5 +160,25 @@ (declaim (inline compute-hash-code)) (declaim (inline eq-hash-find eq-hash-find-for-put)) - (declaim (inline lock-hash-table unlock-hash-table))) + (declaim (inline read-lock-hash-table write-lock-hash-table unlock-hash-table)) + (declaim (inline %hash-symbol))) + + + +(defun %hash-symbol (sym) + (if sym + (let* ((vector (%symptr->symvector sym)) + (cell (%svref vector target::symbol.plist-cell))) + (or (car cell) + (let* ((pname (%svref vector target::symbol.pname-cell)) + (hash (mixup-hash-code (%pname-hash pname (uvsize pname))))) + (declare (type (simple-string pname))) + (if cell + (setf (car cell) hash) + (progn + (setf (%svref vector target::symbol.plist-cell) + (cons hash nil)) + hash))))) + +nil-hash+)) + (defun %cons-hash-table (rehash-function keytrans-function compare-function vector @@ -187,4 +207,5 @@ find ; nhash.find find-new ; nhash.find-new + nil ; hhash.read-only )) @@ -291,6 +312,5 @@ (values (mixup-hash-code (instance.hash key)) nil) (if (symbolp key) - (let* ((name (if key (%svref (symptr->symvector key) target::symbol.pname-cell) "NIL"))) - (values (mixup-hash-code (%pname-hash name (length name))) nil)) + (values (%hash-symbol key) nil) (let ((hash (mixup-hash-code (strip-tag-to-fixnum key)))) (if (immediate-p-macro key) @@ -340,16 +360,4 @@ (mixup-hash-code (strip-tag-to-fixnum primary)))))) -;; call %%eqlhash - -(defun string-hash (key start len) - (declare (fixnum start len)) - (let* ((res len)) - (dotimes (i len) - (let ((code (%scharcode key (%i+ i start)))) - (setq code (mixup-hash-code code)) - (setq res (%i+ (rotate-hash-code res) code)))) - res)) - - (defun %%equalhash (key) @@ -365,9 +373,9 @@ ((and hash (neq hash key)) hash) ; eql stuff (t (typecase key - (simple-string (string-hash key 0 (length key))) + (simple-string (%pname-hash key (length key))) (string (let ((length (length key))) (multiple-value-bind (data offset) (array-data-and-offset key) - (string-hash data offset length)))) + (%string-hash offset data length)))) (bit-vector (bit-vector-hash key)) (cons @@ -567,7 +575,38 @@ - - - +(defvar *continue-from-readonly-hashtable-lock-error* nil) + +(defun signal-read-only-hash-table-error (hash) + (cond (*continue-from-readonly-hashtable-lock-error* + (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!" + "Hash-table ~s is readonly" hash) + (assert-hash-table-writeable hash) + (write-lock-hash-table hash)) + (t (error "Hash-table ~s is readonly" hash)))) + +(defun read-lock-hash-table (hash) + (if (nhash.read-only hash) + :readonly + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (read-lock-rwlock lock) + (unless (eq (nhash.owner hash) *current-process*) + (error "Not owner of hash table ~s" hash)))))) + +(defun write-lock-hash-table (hash) + (if (nhash.read-only hash) + (signal-read-only-hash-table-error hash) + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (write-lock-rwlock lock) + (unless (eq (nhash.owner hash) *current-process*) + (error "Not owner of hash table ~s" hash)))))) + + +(defun unlock-hash-table (hash was-readonly) + (unless was-readonly + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (unlock-rwlock lock))))) @@ -578,28 +617,29 @@ (unless (hash-table-p hash) (report-bad-arg hash 'hash-table)) - (without-interrupts - (lock-hash-table hash) - (let* ((vector (nhash.vector hash)) - (size (nhash.vector-size vector)) - (count (+ size size)) - (index $nhash.vector_overhead)) - (declare (fixnum size count index)) - (dotimes (i count) - (setf (%svref vector index) (%unbound-marker)) - (incf index)) - (incf (the fixnum (nhash.grow-threshold hash)) - (the fixnum (+ (the fixnum (nhash.count hash)) - (the fixnum (nhash.vector.deleted-count vector))))) - (setf (nhash.count hash) 0 - (nhash.vector.cache-key vector) (%unbound-marker) - (nhash.vector.cache-value vector) nil - (nhash.vector.finalization-alist vector) nil - (nhash.vector.free-alist vector) nil - (nhash.vector.weak-deletions-count vector) 0 - (nhash.vector.deleted-count vector) 0 - (nhash.vector.flags vector) (logand $nhash_weak_flags_mask - (nhash.vector.flags vector)))) - (unlock-hash-table hash) - hash)) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (let* ((vector (nhash.vector hash)) + (size (nhash.vector-size vector)) + (count (+ size size)) + (index $nhash.vector_overhead)) + (declare (fixnum size count index)) + (dotimes (i count) + (setf (%svref vector index) (%unbound-marker)) + (incf index)) + (incf (the fixnum (nhash.grow-threshold hash)) + (the fixnum (+ (the fixnum (nhash.count hash)) + (the fixnum (nhash.vector.deleted-count vector))))) + (setf (nhash.count hash) 0 + (nhash.vector.cache-key vector) (%unbound-marker) + (nhash.vector.cache-value vector) nil + (nhash.vector.finalization-alist vector) nil + (nhash.vector.free-alist vector) nil + (nhash.vector.weak-deletions-count vector) 0 + (nhash.vector.deleted-count vector) 0 + (nhash.vector.flags vector) (logand $nhash_weak_flags_mask + (nhash.vector.flags vector)))) + (unlock-hash-table hash nil) + hash))) (defun index->vector-index (index) @@ -654,15 +694,4 @@ -(defun lock-hash-table (hash) - (let* ((lock (nhash.exclusion-lock hash))) - (if lock - (write-lock-rwlock lock) - (progn (unless (eq (nhash.owner hash) *current-process*) - (error "Not owner of hash table ~s" hash)))))) - -(defun unlock-hash-table (hash) - (let* ((lock (nhash.exclusion-lock hash))) - (if lock - (unlock-rwlock lock)))) (defun gethash (key hash &optional default) @@ -675,35 +704,42 @@ (vector-key nil) (gc-locked nil) + (readonly nil) (foundp nil)) - (without-interrupts - (lock-hash-table hash) - (let* ((vector (nhash.vector hash))) - (if (and (eq key (nhash.vector.cache-key vector)) - ;; Check twice: the GC might nuke the cached key/value pair - (progn (setq value (nhash.vector.cache-value vector)) - (eq key (nhash.vector.cache-key vector)))) - (setq foundp t) - (loop - (let* ((vector-index (funcall (nhash.find hash) hash key))) - (declare (fixnum vector-index)) - ;; Referencing both key and value here - and referencing - ;; value first - is an attempt to compensate for the - ;; possibility that the GC deletes a weak-on-key pair. - (setq value (%svref vector (the fixnum (1+ vector-index))) - vector-key (%svref vector vector-index)) - (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker)) - (not (eq vector-key deleted-hash-key-marker)))) - (setf (nhash.vector.cache-key vector) vector-key - (nhash.vector.cache-value vector) value - (nhash.vector.cache-idx vector) (vector-index->index - vector-index)) - (return)) - ((%needs-rehashing-p hash) - (setq gc-locked t) - (%lock-gc-lock) - (%rehash hash)) - (t (return))))))) - (when gc-locked (%unlock-gc-lock)) - (unlock-hash-table hash)) + (with-lock-context + (without-interrupts + (setq readonly (eq (read-lock-hash-table hash) :readonly)) + (let* ((vector (nhash.vector hash))) + (if (and (eq key (nhash.vector.cache-key vector)) + ;; Check twice: the GC might nuke the cached key/value pair + (progn (setq value (nhash.vector.cache-value vector)) + (eq key (nhash.vector.cache-key vector)))) + (setq foundp t) + (loop + (let* ((vector-index (funcall (nhash.find hash) hash key))) + (declare (fixnum vector-index)) + ;; Referencing both key and value here - and referencing + ;; value first - is an attempt to compensate for the + ;; possibility that the GC deletes a weak-on-key pair. + (setq value (%svref vector (the fixnum (1+ vector-index))) + vector-key (%svref vector vector-index)) + (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker)) + (not (eq vector-key deleted-hash-key-marker)))) + #+no + (setf (nhash.vector.cache-key vector) vector-key + (nhash.vector.cache-value vector) value + (nhash.vector.cache-idx vector) (vector-index->index + vector-index)) + (return)) + ((%needs-rehashing-p hash) + (%lock-gc-lock) + (setq gc-locked t) + (unless readonly + (let* ((lock (nhash.exclusion-lock hash))) + (when lock (%promote-rwlock lock)))) + (when (%needs-rehashing-p hash) + (%rehash hash))) + (t (return))))))) + (when gc-locked (%unlock-gc-lock)) + (unlock-hash-table hash readonly))) (if foundp (values value t) @@ -716,71 +752,56 @@ (setq hash (require-type hash 'hash-table))) (let* ((foundp nil)) - (without-interrupts - (lock-hash-table hash) - (%lock-gc-lock) - (when (%needs-rehashing-p hash) - (%rehash hash)) - (let* ((vector (nhash.vector hash))) - (if (eq key (nhash.vector.cache-key vector)) - (progn - (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator))) - ((null iterator)) - (unless (= (the fixnum (hti.index iterator)) - (the fixnum (nhash.vector.cache-idx vector))) - (unlock-hash-table hash) - (%unlock-gc-lock) - (error "Can't remove key ~s during iteration on hash-table ~s" - key hash))) - (setf (nhash.vector.cache-key vector) free-hash-key-marker - (nhash.vector.cache-value vector) nil) - (let ((vidx (index->vector-index (nhash.vector.cache-idx vector)))) - (setf (%svref vector vidx) deleted-hash-key-marker) - (setf (%svref vector (the fixnum (1+ vidx))) nil)) - (incf (the fixnum (nhash.vector.deleted-count vector))) - (decf (the fixnum (nhash.count hash))) - (setq foundp t)) - (let* ((vector-index (funcall (nhash.find hash) hash key)) - (vector-key (%svref vector vector-index))) - (declare (fixnum vector-index)) - (when (setq foundp (and (not (eq vector-key free-hash-key-marker)) - (not (eq vector-key deleted-hash-key-marker)))) - (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator))) - ((null iterator)) - (unless (= (the fixnum (hti.index iterator)) - (the fixnum (vector-index->index vector-index))) - (unlock-hash-table hash) - (%unlock-gc-lock) - (error "Can't remove key ~s during iteration on hash-table ~s" - key hash))) - ;; always clear the cache cause I'm too lazy to call the - ;; comparison function and don't want to keep a possibly - ;; deleted key from being GC'd + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (%lock-gc-lock) + (when (%needs-rehashing-p hash) + (%rehash hash)) + (let* ((vector (nhash.vector hash))) + (if (eq key (nhash.vector.cache-key vector)) + (progn (setf (nhash.vector.cache-key vector) free-hash-key-marker (nhash.vector.cache-value vector) nil) - ;; Update the count + (let ((vidx (index->vector-index (nhash.vector.cache-idx vector)))) + (setf (%svref vector vidx) deleted-hash-key-marker) + (setf (%svref vector (the fixnum (1+ vidx))) nil)) (incf (the fixnum (nhash.vector.deleted-count vector))) (decf (the fixnum (nhash.count hash))) - ;; Remove a cons from the free-alist if the table is finalizeable - (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector)) - (pop (the list (svref nhash.vector.free-alist vector)))) - ;; Delete the value from the table. - (setf (%svref vector vector-index) deleted-hash-key-marker - (%svref vector (the fixnum (1+ vector-index))) nil)))) - (when (and foundp - (zerop (the fixnum (nhash.count hash)))) - (do* ((i $nhash.vector_overhead (1+ i)) - (n (uvsize vector))) - ((= i n)) - (declare (fixnum i n)) - (setf (%svref vector i) free-hash-key-marker)) - (setf (nhash.grow-threshold hash) - (+ (nhash.vector.deleted-count vector) - (nhash.vector.weak-deletions-count vector) - (nhash.grow-threshold hash)) - (nhash.vector.deleted-count vector) 0 - (nhash.vector.weak-deletions-count vector) 0))) - ;; Return T if we deleted something - (%unlock-gc-lock) - (unlock-hash-table hash)) + (setq foundp t)) + (let* ((vector-index (funcall (nhash.find hash) hash key)) + (vector-key (%svref vector vector-index))) + (declare (fixnum vector-index)) + (when (setq foundp (and (not (eq vector-key free-hash-key-marker)) + (not (eq vector-key deleted-hash-key-marker)))) + ;; always clear the cache cause I'm too lazy to call the + ;; comparison function and don't want to keep a possibly + ;; deleted key from being GC'd + (setf (nhash.vector.cache-key vector) free-hash-key-marker + (nhash.vector.cache-value vector) nil) + ;; Update the count + (incf (the fixnum (nhash.vector.deleted-count vector))) + (decf (the fixnum (nhash.count hash))) + ;; Remove a cons from the free-alist if the table is finalizeable + (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector)) + (pop (the list (svref nhash.vector.free-alist vector)))) + ;; Delete the value from the table. + (setf (%svref vector vector-index) deleted-hash-key-marker + (%svref vector (the fixnum (1+ vector-index))) nil)))) + (when (and foundp + (zerop (the fixnum (nhash.count hash)))) + (do* ((i $nhash.vector_overhead (1+ i)) + (n (uvsize vector))) + ((= i n)) + (declare (fixnum i n)) + (setf (%svref vector i) free-hash-key-marker)) + (setf (nhash.grow-threshold hash) + (+ (nhash.vector.deleted-count vector) + (nhash.vector.weak-deletions-count vector) + (nhash.grow-threshold hash)) + (nhash.vector.deleted-count vector) 0 + (nhash.vector.weak-deletions-count vector) 0))) + ;; Return T if we deleted something + (%unlock-gc-lock) + (unlock-hash-table hash nil))) foundp)) @@ -789,66 +810,55 @@ (unless (hash-table-p hash) (report-bad-arg hash 'hash-table)) - (without-interrupts - (block protected - (tagbody - (lock-hash-table hash) + (with-lock-context + (without-interrupts + (block protected + (tagbody + (write-lock-hash-table hash) AGAIN - (%lock-gc-lock) - (when (%needs-rehashing-p hash) - (%rehash hash)) - (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator))) - ((null iterator)) - (let* ((vector (hti.vector iterator)) - (index (index->vector-index (hti.index iterator))) - (test (hash-table-test hash))) - (declare (fixnum index)) - (when (and (< index (the fixnum (uvsize vector))) - (not (funcall test (%svref vector index) key))) - (unlock-hash-table hash) - (%unlock-gc-lock) - (error "Can't add key ~s during iteration on hash-table ~s" - key hash)))) - (let ((vector (nhash.vector hash))) - (when (eq key (nhash.vector.cache-key vector)) - (let* ((idx (nhash.vector.cache-idx vector))) - (declare (fixnum idx)) - (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx))))) - value) - (setf (nhash.vector.cache-value vector) value) - (return-from protected))) - (let* ((vector-index (funcall (nhash.find-new hash) hash key)) - (old-value (%svref vector vector-index))) - (declare (fixnum vector-index)) - - (cond ((eq old-value deleted-hash-key-marker) - (%set-hash-table-vector-key vector vector-index key) - (setf (%svref vector (the fixnum (1+ vector-index))) value) - (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash))))) - ;; Adjust deleted-count - (when (> 0 (the fixnum - (decf (the fixnum - (nhash.vector.deleted-count vector))))) - (let ((weak-deletions (nhash.vector.weak-deletions-count vector))) - (declare (fixnum weak-deletions)) - (setf (nhash.vector.weak-deletions-count vector) 0) - (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions) - (decf (the fixnum (nhash.count hash)) weak-deletions)))) - ((eq old-value free-hash-key-marker) - (when (eql 0 (nhash.grow-threshold hash)) - (%unlock-gc-lock) - (grow-hash-table hash) - (go AGAIN)) - (%set-hash-table-vector-key vector vector-index key) - (setf (%svref vector (the fixnum (1+ vector-index))) value) - (decf (the fixnum (nhash.grow-threshold hash))) - (incf (the fixnum (nhash.count hash)))) - (t - ;; Key was already there, update value. - (setf (%svref vector (the fixnum (1+ vector-index))) value))) - (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index) - (nhash.vector.cache-key vector) key - (nhash.vector.cache-value vector) value))))) - (%unlock-gc-lock) - (unlock-hash-table hash)) + (%lock-gc-lock) + (when (%needs-rehashing-p hash) + (%rehash hash)) + (let ((vector (nhash.vector hash))) + (when (eq key (nhash.vector.cache-key vector)) + (let* ((idx (nhash.vector.cache-idx vector))) + (declare (fixnum idx)) + (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx))))) + value) + (setf (nhash.vector.cache-value vector) value) + (return-from protected))) + (let* ((vector-index (funcall (nhash.find-new hash) hash key)) + (old-value (%svref vector vector-index))) + (declare (fixnum vector-index)) + + (cond ((eq old-value deleted-hash-key-marker) + (%set-hash-table-vector-key vector vector-index key) + (setf (%svref vector (the fixnum (1+ vector-index))) value) + (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash))))) + ;; Adjust deleted-count + (when (> 0 (the fixnum + (decf (the fixnum + (nhash.vector.deleted-count vector))))) + (let ((weak-deletions (nhash.vector.weak-deletions-count vector))) + (declare (fixnum weak-deletions)) + (setf (nhash.vector.weak-deletions-count vector) 0) + (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions) + (decf (the fixnum (nhash.count hash)) weak-deletions)))) + ((eq old-value free-hash-key-marker) + (when (eql 0 (nhash.grow-threshold hash)) + (%unlock-gc-lock) + (grow-hash-table hash) + (go AGAIN)) + (%set-hash-table-vector-key vector vector-index key) + (setf (%svref vector (the fixnum (1+ vector-index))) value) + (decf (the fixnum (nhash.grow-threshold hash))) + (incf (the fixnum (nhash.count hash)))) + (t + ;; Key was already there, update value. + (setf (%svref vector (the fixnum (1+ vector-index))) value))) + (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index) + (nhash.vector.cache-key vector) key + (nhash.vector.cache-value vector) value))))) + (%unlock-gc-lock) + (unlock-hash-table hash nil))) value) @@ -1013,4 +1023,5 @@ + (defun %hash-probe (hash key update-hash-flags) (declare (optimize (speed 3) (space 0))) @@ -1076,8 +1087,5 @@ (mixup-hash-code (instance.hash key)) (if (symbolp key) - (let* ((name (if key (%svref - (symptr->symvector key) - target::symbol.pname-cell) "NIL"))) - (mixup-hash-code (%pname-hash name (length name)))) + (%hash-symbol key) (mixup-hash-code (strip-tag-to-fixnum key))))))) (length (uvsize vector)) @@ -1125,8 +1133,5 @@ (mixup-hash-code (instance.hash key)) (if (symbolp key) - (let* ((name (if key (%svref - (symptr->symvector key) - target::symbol.pname-cell) "NIL"))) - (mixup-hash-code (%pname-hash name (length name)))) + (%hash-symbol key) (progn (unless (immediate-p-macro key) @@ -1680,2 +1685,101 @@ vector)) +(defun assert-hash-table-readonly (hash) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (or (nhash.read-only hash) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (let* ((flags (nhash.vector.flags (nhash.vector hash)))) + (declare (fixnum flags)) + (when (or (logbitp $nhash_track_keys_bit flags) + (logbitp $nhash_component_address_bit flags)) + (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash) + (unlock-hash-table hash nil) + (return-from assert-hash-table-readonly nil)) + (setf (nhash.read-only hash) t) + (unlock-hash-table hash nil) + t))))) + +;; This is dangerous, if multiple threads are accessing a read-only +;; hash table. Use it responsibly. +(defun assert-hash-table-writeable (hash) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (when (nhash.read-only hash) + (setf (nhash.read-only hash) nil) + t)) + +(defun readonly-hash-table-p (hash) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (nhash.read-only hash)) + +(defun hash-table-owner (hash) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (nhash.owner hash)) + +(defun claim-hash-table (hash &optional steal) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (let* ((owner (nhash.owner hash))) + (if owner + (or (eq owner *current-process*) + (when steal + (setf (nhash.owner hash) *current-process*))) + (progn + (write-lock-hash-table hash) + (setf (nhash.exclusion-lock hash) nil + (nhash.owner hash) *current-process*) + t)))) + + + + + +(defun enumerate-hash-keys (hash out) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (with-lock-context + (without-interrupts + (let* ((readonly (eq (read-lock-hash-table hash) :readonly))) + (do* ((in (nhash.vector hash)) + (in-idx $nhash.vector_overhead (+ in-idx 2)) + (insize (uvsize in)) + (outsize (length out)) + (out-idx 0)) + ((or (= in-idx insize) + (= out-idx outsize)) + (unlock-hash-table hash readonly) + out-idx) + (declare (fixnum in-idx insize out-idx outsize)) + (let* ((val (%svref in in-idx))) + (unless (or (eq val free-hash-key-marker) + (eq val deleted-hash-key-marker)) + (setf (%svref out out-idx) val) + (incf out-idx)))))))) + +(defun enumerate-hash-keys-and-values (hash keys values) + (unless (hash-table-p hash) + (report-bad-arg hash 'hash-table)) + (with-lock-context + (without-interrupts + (let* ((readonly (eq (read-lock-hash-table hash) :readonly))) + (do* ((in (nhash.vector hash)) + (in-idx $nhash.vector_overhead (+ in-idx 2)) + (insize (uvsize in)) + (outsize (length keys)) + (out-idx 0)) + ((or (= in-idx insize) + (= out-idx outsize)) + (unlock-hash-table hash readonly) + out-idx) + (declare (fixnum in-idx insize out-idx outsize)) + (let* ((key (%svref in in-idx))) + (unless (or (eq key free-hash-key-marker) + (eq key deleted-hash-key-marker)) + (setf (%svref keys out-idx) key) + (setf (%svref values out-idx) (%svref in (the fixnum (1+ in-idx)))) + (incf out-idx)))))))) Index: /branches/event-ide/ccl/level-0/l0-init.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-init.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-init.lisp (revision 8262) @@ -92,4 +92,7 @@ "a list of symbols that describe features provided by the implementation") + +(defparameter *optional-features* () "Set by build process") + (defparameter *load-verbose* nil "the default for the :VERBOSE argument to LOAD") Index: /branches/event-ide/ccl/level-0/l0-io.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-io.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-io.lisp (revision 8262) @@ -31,5 +31,134 @@ -; write nbytes bytes from buffer buf to file-descriptor fd. +(defun utf-8-octets-in-string (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (incf noctets + (if (< code #x80) + 1 + (if (< code #x800) + 2 + (if (< code #x10000) + 3 + 4)))))) + 0)) + +(defun utf-8-memory-encode (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx)) + ((< code #x800) + (setf (%get-unsigned-byte pointer idx) + (logior #xc0 (the fixnum (ash code -6)))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 2)) + ((< code #x10000) + (setf (%get-unsigned-byte pointer idx) + (logior #xe0 (the fixnum (ash code -12)))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 3)) + (t + (setf (%get-unsigned-byte pointer idx) + (logior #xf0 + (the fixnum (logand #x7 (the fixnum (ash code -18)))))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) + (logand #x3f code)) + (incf idx 4)))))) + +(defun utf-8-memory-decode (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) (if (= index end) index 0)) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((char (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 2nd-unit)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor 2nd-unit #x80))))) + (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 3rd-unit)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= 2nd-unit #xa0))) + (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 2nd-unit #x3f)) + 6)) + (the fixnum (logand 3rd-unit #x3f)))))))) + (if (< 1st-unit #xf8) + (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 4th-unit)) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (< (the fixnum (logxor 4th-unit #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= 2nd-unit #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor 3rd-unit #x80)) 6)) + (the fixnum (logxor 4th-unit #x80))))))))))))))))) + (setf (schar string i) (or char #\Replacement_Character)))))) + +(defun utf-8-length-of-memory-encoding (pointer noctets start) + (do* ((i start) + (end (+ start noctets)) + (nchars 0 (1+ nchars))) + ((= i end) (values nchars i)) + (let* ((code (%get-unsigned-byte pointer i)) + (nexti (+ i (cond ((< code #x80) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + (t 4))))) + (declare (type (unsigned-byte 8) code)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti))))) + + + +;;; write nbytes bytes from buffer buf to file-descriptor fd. (defun fd-write (fd buf nbytes) (syscall syscalls::write fd buf nbytes)) @@ -42,6 +171,13 @@ (defun fd-open (path flags &optional (create-mode #o666)) - (with-cstrs ((p path)) - (syscall syscalls::open p flags create-mode))) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path)) + (let* ((fd (syscall syscalls::open p flags create-mode))) + (declare (fixnum fd)) + (when (or (= fd (- #$EMFILE)) + (= fd (- #$EMFILE))) + (gc) + (drain-termination-queue) + (setq fd (syscall syscalls::open p flags create-mode))) + fd))) (defun fd-chmod (fd mode) Index: /branches/event-ide/ccl/level-0/l0-misc.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-misc.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-misc.lisp (revision 8262) @@ -17,5 +17,43 @@ (in-package "CCL") -; Miscellany. + +(defparameter *locks-held* () "per-thread list of held locks") +(defparameter *locks-pending* () "per-thread list of locks we're waiting for.") +(defparameter *lock-conses* ()) + +;; Cold-load lossage. +#+lock-accounting +(setq *lock-conses* (make-list 20)) + +;;; Per-thread consing, for lock-ownership tracking. +#+lock-accounting +(defun %lock-cons (x y) + (let* ((cell (prog1 *lock-conses* + (setq *lock-conses* (cdr *lock-conses*))))) + (if cell + (progn + (rplaca cell x) + (rplacd cell y)) + (cons x y)))) + + +;;; Bootstrapping for futexes +#+(and linuxx8664-target) +(eval-when (:compile-toplevel :execute) + (pushnew :futex *features*)) + +#+futex +(eval-when (:compile-toplevel :execute) + ;; We only need a few constants from , which may + ;; not have been included in the :libc .cdb files. + (defconstant FUTEX-WAIT 0) + (defconstant FUTEX-WAKE 1) + (defconstant futex-avail 0) + (defconstant futex-locked 1) + (defconstant futex-contended 2) + (require "X8664-LINUX-SYSCALLS") + (declaim (inline %lock-futex %unlock-futex))) + +;;; Miscellany. (defun memq (item list) @@ -129,5 +167,8 @@ t) - +(defun frozen-space-dnodes () + "Returns the current size of the frozen area." + (%fixnum-ref-natural (%get-kernel-global 'tenured-area) + target::area.static-dnodes)) (defun %usedbytes () (%normalize-areas) @@ -147,7 +188,7 @@ (incf library bytes) (incf static bytes)))))) - (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift))) - (decf dynamic hons-size) - (values dynamic static library hons-size)))) + (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift))) + (decf dynamic frozen-size) + (values dynamic static library frozen-size)))) @@ -199,11 +240,11 @@ -; Returns six values. -; sp free -; sp used -; vsp free -; vsp used -; tsp free -; tsp used +;;; Returns six values. +;;; sp free +;;; sp used +;;; vsp free +;;; vsp used +;;; tsp free +;;; tsp used (defun %thread-stack-space (&optional (thread *current-lisp-thread*)) (when (eq thread *current-lisp-thread*) @@ -267,5 +308,5 @@ (static-used nil) (staticlib-used nil) - (hons-space-size nil) + (frozen-space-size nil) (lispheap nil) (reserved nil) @@ -275,17 +316,17 @@ (stack-free) (stack-used-by-thread nil)) - (with-other-threads-suspended - (without-gcing - (setq freebytes (%freebytes)) - (when verbose - (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size) - (%usedbytes)) - (setq lispheap (+ freebytes usedbytes) - reserved (%reservedbytes) - static (+ static-used staticlib-used hons-space-size)) - (multiple-value-setq (stack-total stack-used stack-free) - (%stack-space)) - (unless (eq verbose :default) - (setq stack-used-by-thread (%stack-space-by-lisp-thread)))))) + (progn + (progn + (setq freebytes (%freebytes)) + (when verbose + (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size) + (%usedbytes)) + (setq lispheap (+ freebytes usedbytes) + reserved (%reservedbytes) + static (+ static-used staticlib-used frozen-space-size)) + (multiple-value-setq (stack-total stack-used stack-free) + (%stack-space)) + (unless (eq verbose :default) + (setq stack-used-by-thread (%stack-space-by-lisp-thread)))))) (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes) (when verbose @@ -305,7 +346,7 @@ 0 0 static (k static)) - (when (and hons-space-size (not (zerop hons-space-size))) - (format t "~&~,3f MB of static memory reserved for hash consing." - (/ hons-space-size (float (ash 1 20))))) + (when (and frozen-space-size (not (zerop frozen-space-size))) + (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory" + (/ frozen-space-size (float (ash 1 20))))) (format t "~&~,3f MB reserved for heap expansion." (/ reserved (float (ash 1 20)))) @@ -390,4 +431,13 @@ (declare (fixnum end)))) +(defun %get-utf-8-cstring (pointer) + (do* ((end 0 (1+ end))) + ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) + (let* ((len (utf-8-length-of-memory-encoding pointer end 0)) + (string (make-string len))) + (utf-8-memory-decode pointer end 0 string) + string)) + (declare (fixnum end)))) + ;;; This is mostly here so we can bootstrap shared libs without ;;; having to bootstrap #_strcmp. @@ -467,5 +517,7 @@ (defparameter *spin-lock-tries* 1) - +(defparameter *spin-lock-timeouts* 0) + +#+(and (not futex) (not x86-target)) (defun %get-spin-lock (p) (let* ((self (%current-tcr)) @@ -476,55 +528,170 @@ (when (eql 0 (%ptr-store-fixnum-conditional p 0 self)) (return-from %get-spin-lock t))) + (%atomic-incf-node 1 '*spin-lock-timeouts* target::symbol.vcell) (yield)))) -(defun %lock-recursive-lock (lock &optional flag) - (with-macptrs ((p) - (owner (%get-ptr lock target::lockptr.owner)) - (signal (%get-ptr lock target::lockptr.signal)) - (spin (%inc-ptr lock target::lockptr.spinlock))) - (%setf-macptr-to-object p (%current-tcr)) - (if (istruct-typep flag 'lock-acquisition) - (setf (lock-acquisition.status flag) nil) - (if flag (report-bad-arg flag 'lock-acquisition))) - (loop +(eval-when (:compile-toplevel :execute) + (declaim (inline note-lock-wait note-lock-held note-lock-released))) + +(defun note-lock-wait (lock) + #+lock-accounting + (setq *locks-pending* (%lock-cons lock *locks-pending*)) + #-lock-accounting (declare (ignore lock))) + +(defun note-lock-held () + #+lock-accounting + (let* ((p *locks-pending*)) + (setq *locks-pending* (cdr *locks-pending*)) + (rplacd p *locks-held*) + (setq *locks-held* p))) + +(defun note-lock-released () + #+lock-accounting + (setf (car *locks-held*) nil + *locks-held* (cdr *locks-held*))) + +#-futex +(defun %lock-recursive-lock-object (lock &optional flag) + (let* ((ptr (recursive-lock-ptr lock))) + (with-macptrs ((p) + (owner (%get-ptr ptr target::lockptr.owner)) + (signal (%get-ptr ptr target::lockptr.signal)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (%setf-macptr-to-object p (%current-tcr)) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (note-lock-wait lock) + (loop + (without-interrupts + (when (eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + (note-lock-held) + (when flag + (setf (lock-acquisition.status flag) t)) + (return t)) + (%get-spin-lock spin) + (when (eql 1 (incf (%get-natural ptr target::lockptr.avail))) + (setf (%get-ptr ptr target::lockptr.owner) p + (%get-natural ptr target::lockptr.count) 1) + (setf (%get-natural spin 0) 0) + (note-lock-held) + (if flag + (setf (lock-acquisition.status flag) t)) + (return t)) + (setf (%get-natural spin 0) 0)) + (%process-wait-on-semaphore-ptr signal 1 0 (recursive-lock-whostate lock)))))) + + + +#+futex +(progn + #-monitor-futex-wait + (defun futex-wait (p val whostate) + (with-process-whostate (whostate) + (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0))) + #+monitor-futex-wait + (progn + (defparameter *total-futex-wait-calls* 0) + (defparameter *total-futex-wait-times* 0) + (defun futex-wait (p val whostate) + (with-process-whostate (whostate) + (let* ((start (get-internal-real-time))) + (incf *total-futex-wait-calls*) + (syscall syscalls::futex p FUTEX-WAIT val (%null-ptr) (%null-ptr) 0) + (incf *total-futex-wait-times* (- (get-internal-real-time) start))))))) + + + + +#+futex +(defun futex-wake (p n) + (syscall syscalls::futex p FUTEX-WAKE n (%null-ptr) (%null-ptr) 0)) + +#+futex +(defun %lock-futex (p wait-level lock fwhostate) + (let* ((val (%ptr-store-conditional p futex-avail futex-locked))) + (declare (fixnum val)) + (or (eql val futex-avail) + (loop + (if (eql val futex-contended) + (let* ((*interrupt-level* wait-level)) + (futex-wait p val (if fwhostate (funcall fwhostate lock) "futex wait"))) + (setq val futex-contended)) + (when (eql futex-avail (xchgl val p)) + (return t)))))) + +#+futex +(defun %unlock-futex (p) + (unless (eql futex-avail (%atomic-decf-ptr p)) + (setf (%get-natural p target::lockptr.avail) futex-avail) + (futex-wake p #$INT_MAX))) + + + + +#+futex +(defun %lock-recursive-lock-object (lock &optional flag) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((self (%current-tcr)) + (level *interrupt-level*) + (ptr (recursive-lock-ptr lock))) + (declare (fixnum self val)) + (note-lock-wait lock) + (without-interrupts + (cond ((eql self (%get-object ptr target::lockptr.owner)) + (incf (%get-natural ptr target::lockptr.count))) + (t (%lock-futex ptr level lock #'recursive-lock-whostate) + (%set-object ptr target::lockptr.owner self) + (setf (%get-natural ptr target::lockptr.count) 1))) + (note-lock-held) + (when flag + (setf (lock-acquisition.status flag) t)) + t))) + + + + + + +#-futex +(defun %try-recursive-lock-object (lock &optional flag) + (let* ((ptr (recursive-lock-ptr lock))) + (with-macptrs ((p) + (owner (%get-ptr ptr target::lockptr.owner)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (%setf-macptr-to-object p (%current-tcr)) + (if flag + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (report-bad-arg flag 'lock-acquisition))) (without-interrupts - (when (eql p owner) - (incf (%get-natural lock target::lockptr.count)) - (when flag - (setf (lock-acquisition.status flag) t)) - (return t)) - (%get-spin-lock spin) - (when (eql 1 (incf (%get-natural lock target::lockptr.avail))) - (setf (%get-ptr lock target::lockptr.owner) p - (%get-natural lock target::lockptr.count) 1) - (setf (%get-natural spin 0) 0) - (if flag - (setf (lock-acquisition.status flag) t)) - (return t)) - (setf (%get-natural spin 0) 0)) - (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock")))) - - -;;; Locking the exception lock to inhibit GC (from other threads) -;;; is probably a bad idea, though it does simplify some issues. -;;; (One bad consequence is that it means that only one hash table -;;; can be accessed at a time.) -#+bad-idea -(defun %lock-gc-lock () - (with-macptrs ((lock)) - (%get-kernel-global-ptr exception-lock lock) - (%lock-recursive-lock lock))) - -#+bad-idea -(defun %unlock-gc-lock () - (with-macptrs ((lock)) - (%get-kernel-global-ptr exception-lock lock) - (%unlock-recursive-lock lock))) - -(defun %try-recursive-lock (lock &optional flag) - (with-macptrs ((p) - (owner (%get-ptr lock target::lockptr.owner)) - (spin (%inc-ptr lock target::lockptr.spinlock))) - (%setf-macptr-to-object p (%current-tcr)) + (cond ((eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + #+lock-accounting + (setq *locks-held* (%lock-cons lock *locks-held*)) + (if flag (setf (lock-acquisition.status flag) t)) + t) + (t + (let* ((win nil)) + (%get-spin-lock spin) + (when (setq win (eql 1 (incf (%get-natural ptr target::lockptr.avail)))) + (setf (%get-ptr ptr target::lockptr.owner) p + (%get-natural ptr target::lockptr.count) 1) + #+lock-accounting + (setq *locks-held* (%lock-cons lock *locks-held*)) + (if flag (setf (lock-acquisition.status flag) t))) + (setf (%get-ptr spin) (%null-ptr)) + win))))))) + + + +#+futex +(defun %try-recursive-lock-object (lock &optional flag) + (let* ((self (%current-tcr)) + (ptr (recursive-lock-ptr lock))) + (declare (fixnum self)) (if flag (if (istruct-typep flag 'lock-acquisition) @@ -532,42 +699,66 @@ (report-bad-arg flag 'lock-acquisition))) (without-interrupts - (cond ((eql p owner) - (incf (%get-natural lock target::lockptr.count)) + (cond ((eql (%get-object ptr target::lockptr.owner) self) + (incf (%get-natural ptr target::lockptr.count)) + #+lock-accounting* + (setq *locks-held* (%lock-cons lock *locks-held*)) (if flag (setf (lock-acquisition.status flag) t)) t) (t - (let* ((win nil)) - (%get-spin-lock spin) - (when (setq win (eql 1 (incf (%get-natural lock target::lockptr.avail)))) - (setf (%get-ptr lock target::lockptr.owner) p - (%get-natural lock target::lockptr.count) 1) - (if flag (setf (lock-acquisition.status flag) t))) - (setf (%get-ptr spin) (%null-ptr)) - win)))))) - - -(defun %unlock-recursive-lock (lock) - (with-macptrs ((signal (%get-ptr lock target::lockptr.signal)) - (spin (%inc-ptr lock target::lockptr.spinlock))) - (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr)) - (error 'not-lock-owner :lock lock)) + (when (eql 0 (%ptr-store-conditional ptr futex-avail futex-locked)) + (%set-object ptr target::lockptr.owner self) + (setf (%get-natural ptr target::lockptr.count) 1) + #+lock-accounting + (setq *locks-held* (%lock-cons lock *locks-held*)) + (if flag (setf (lock-acquisition.status flag) t)) + t)))))) + + + + + +#-futex +(defun %unlock-recursive-lock-object (lock) + (let* ((ptr (%svref lock target::lock._value-cell))) + (with-macptrs ((signal (%get-ptr ptr target::lockptr.signal)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr)) + (error 'not-lock-owner :lock lock)) + (without-interrupts + (when (eql 0 (decf (the fixnum + (%get-natural ptr target::lockptr.count)))) + (note-lock-released) + (%get-spin-lock spin) + (setf (%get-ptr ptr target::lockptr.owner) (%null-ptr)) + (let* ((pending (+ (the fixnum + (1- (the fixnum (%get-fixnum ptr target::lockptr.avail)))) + (the fixnum (%get-fixnum ptr target::lockptr.waiting))))) + (declare (fixnum pending)) + (setf (%get-natural ptr target::lockptr.avail) 0 + (%get-natural ptr target::lockptr.waiting) 0) + (decf pending) + (if (> pending 0) + (setf (%get-natural ptr target::lockptr.waiting) pending)) + (setf (%get-ptr spin) (%null-ptr)) + (if (>= pending 0) + (%signal-semaphore-ptr signal))))))) + nil) + + + +#+futex +(defun %unlock-recursive-lock-object (lock) + (let* ((ptr (%svref lock target::lock._value-cell))) + (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr)) + (cerror "Continue at your own risk" 'not-lock-owner :lock lock)) (without-interrupts (when (eql 0 (decf (the fixnum - (%get-natural lock target::lockptr.count)))) - (%get-spin-lock spin) - (setf (%get-ptr lock target::lockptr.owner) (%null-ptr)) - (let* ((pending (+ (the fixnum - (1- (the fixnum (%get-fixnum lock target::lockptr.avail)))) - (the fixnum (%get-fixnum lock target::lockptr.waiting))))) - (declare (fixnum pending)) - (setf (%get-natural lock target::lockptr.avail) 0 - (%get-natural lock target::lockptr.waiting) 0) - (decf pending) - (if (> pending 0) - (setf (%get-natural lock target::lockptr.waiting) pending)) - (setf (%get-ptr spin) (%null-ptr)) - (if (>= pending 0) - (%signal-semaphore-ptr signal)))))) - nil) + (%get-natural ptr target::lockptr.count)))) + (note-lock-released) + (setf (%get-natural ptr target::lockptr.owner) 0) + (%unlock-futex ptr)))) + nil) + + @@ -616,4 +807,15 @@ (return cell)))))) +(defun atomic-pop-uvector-cell (v i) + (let* ((offset (+ target::misc-data-offset (ash i target::word-shift)))) + (loop + (let* ((old (%svref v i))) + (if (null old) + (return (values nil nil)) + (let* ((tail (cdr old))) + (when (%store-node-conditional offset v old tail) + (return (values (car old) t))))))))) + + (defun store-gvector-conditional (index gvector old new) (%store-node-conditional (+ target::misc-data-offset @@ -640,28 +842,321 @@ (defun %atomic-incf-symbol-value (s &optional (by 1)) (setq s (require-type s 'symbol)) - (let* ((binding-address (%symbol-binding-address s))) - (declare (fixnum binding-address)) - (if (zerop binding-address) - (%atomic-incf-node by s target::symbol.vcell-cell) - (%atomic-incf-node by binding-address (* 2 target::node-size))))) - -(defun write-lock-rwlock (lock) - (let* ((context (%current-tcr))) - (if (eq (%svref lock target::lock.writer-cell) context) - (progn - (decf (%svref lock target::lock._value-cell)) - lock) - (loop - (when (%store-immediate-conditional target::lock._value lock 0 -1) - (setf (%svref lock target::lock.writer-cell) context) - (return lock)) - (%nanosleep 0 *ns-per-tick*))))) - - -(defun read-lock-rwlock (lock) - (loop - (when (%try-read-lock-rwlock lock) - (return lock)) - (%nanosleep 0 *ns-per-tick*))) + (multiple-value-bind (base offset) (%symbol-binding-address s) + (%atomic-incf-node by base offset))) + +;;; What happens if there are some pending readers and another writer, +;;; and we abort out of the semaphore wait ? If the writer semaphore is +;;; signaled before we abandon interest in it +#-futex +(defun %write-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) ) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (note-lock-wait lock) + (without-interrupts + (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (incf (%get-signed-natural ptr target::rwlock.state)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (note-lock-held) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (do* () + ((eql 0 (%get-signed-natural ptr target::rwlock.state)) + ;; That wasn't so bad, was it ? We have the spinlock now. + (note-lock-held) + (setf (%get-signed-natural ptr target::rwlock.state) 1 + (%get-natural ptr target::rwlock.spin) 0) + (%set-object ptr target::rwlock.writer tcr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (incf (%get-natural ptr target::rwlock.blocked-writers)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (let* ((*interrupt-level* level)) + (%process-wait-on-semaphore-ptr write-signal 1 0 (rwlock-write-whostate lock))) + (%get-spin-lock ptr))))))) +#+futex +(defun %write-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) ) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (note-lock-wait lock) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (incf (%get-signed-natural ptr target::rwlock.state)) + (%unlock-futex ptr) + (note-lock-held) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (do* () + ((eql 0 (%get-signed-natural ptr target::rwlock.state)) + ;; That wasn't so bad, was it ? We have the spinlock now. + (note-lock-held) + (setf (%get-signed-natural ptr target::rwlock.state) 1) + (%unlock-futex ptr) + (%set-object ptr target::rwlock.writer tcr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (incf (%get-natural ptr target::rwlock.blocked-writers)) + (let* ((waitval (%get-natural write-signal 0))) + (%unlock-futex ptr) + (with-process-whostate ((rwlock-write-whostate lock)) + (let* ((*interrupt-level* level)) + (futex-wait write-signal waitval (rwlock-write-whostate lock))))) + (%lock-futex ptr level lock nil) + (decf (%get-natural ptr target::rwlock.blocked-writers)))))))) + + + +(defun write-lock-rwlock (lock &optional flag) + (%write-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) + +#-futex +(defun %read-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (note-lock-wait lock) + (without-interrupts + (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (setf (%get-natural ptr target::rwlock.spin) 0) + (setq *locks-pending* (cdr *locks-pending*)) + (error 'deadlock :lock lock)) + (do* ((state + (%get-signed-natural ptr target::rwlock.state) + (%get-signed-natural ptr target::rwlock.state))) + ((<= state 0) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) + (the fixnum (1- state)) + (%get-natural ptr target::rwlock.spin) 0) + (note-lock-held) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (declare (fixnum state)) + (incf (%get-natural ptr target::rwlock.blocked-readers)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (let* ((*interrupt-level* level)) + (%process-wait-on-semaphore-ptr read-signal 1 0 (rwlock-read-whostate lock))) + (%get-spin-lock ptr))))))) + +#+futex +(defun %read-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (note-lock-wait lock) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (%unlock-futex ptr) + (setq *locks-pending* (cdr *locks-pending*)) + (error 'deadlock :lock lock)) + (do* ((state + (%get-signed-natural ptr target::rwlock.state) + (%get-signed-natural ptr target::rwlock.state))) + ((<= state 0) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) + (the fixnum (1- state))) + (note-lock-held) + (%unlock-futex ptr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (declare (fixnum state)) + (incf (%get-natural ptr target::rwlock.blocked-readers)) + (let* ((waitval (%get-natural reader-signal 0))) + (%unlock-futex ptr) + (let* ((*interrupt-level* level)) + (futex-wait reader-signal waitval (rwlock-read-whostate lock)))) + (%lock-futex ptr level lock nil) + (decf (%get-natural ptr target::rwlock.blocked-readers)))))))) + + + +(defun read-lock-rwlock (lock &optional flag) + (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) + + + +#-futex +(defun %unlock-rwlock-ptr (ptr lock) + (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal)) + (writer-signal (%get-ptr ptr target::rwlock.writer-signal))) + (without-interrupts + (%get-spin-lock ptr) + (let* ((state (%get-signed-natural ptr target::rwlock.state)) + (tcr (%current-tcr))) + (declare (fixnum state tcr)) + (cond ((> state 0) + (unless (eql tcr (%get-object ptr target::rwlock.writer)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'not-lock-owner :lock lock)) + (decf state)) + ((< state 0) (incf state)) + (t (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'not-locked :lock lock))) + (setf (%get-signed-natural ptr target::rwlock.state) state) + (when (zerop state) + ;; We want any thread waiting for a lock semaphore to + ;; be able to wait interruptibly. When a thread waits, + ;; it increments either the "blocked-readers" or "blocked-writers" + ;; field, but since it may get interrupted before obtaining + ;; the semaphore that's more of "an expression of interest" + ;; in taking the lock than it is "a firm commitment to take it." + ;; It's generally (much) better to signal the semaphore(s) + ;; too often than it would be to not signal them often + ;; enough; spurious wakeups are better than deadlock. + ;; So: if there are blocked writers, the writer-signal + ;; is raised once for each apparent blocked writer. (At most + ;; one writer will actually succeed in taking the lock.) + ;; If there are blocked readers, the reader-signal is raised + ;; once for each of them. (It's possible for both the + ;; reader and writer semaphores to be raised on the same + ;; unlock; the writer semaphore is raised first, so in that + ;; sense, writers still have priority but it's not guaranteed.) + ;; Both the "blocked-writers" and "blocked-readers" fields + ;; are cleared here (they can't be changed from another thread + ;; until this thread releases the spinlock.) + (note-lock-released) + (setf (%get-signed-natural ptr target::rwlock.writer) 0) + (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) + (nreaders (%get-natural ptr target::rwlock.blocked-readers))) + (declare (fixnum nreaders nwriters)) + (when (> nwriters 0) + (setf (%get-natural ptr target::rwlock.blocked-writers) 0) + (dotimes (i nwriters) + (%signal-semaphore-ptr writer-signal))) + (when (> nreaders 0) + (setf (%get-natural ptr target::rwlock.blocked-readers) 0) + (dotimes (i nreaders) + (%signal-semaphore-ptr reader-signal))))) + (setf (%get-natural ptr target::rwlock.spin) 0) + t)))) + +#+futex +(defun %unlock-rwlock-ptr (ptr lock) + (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)) + (writer-signal (%INC-ptr ptr target::rwlock.writer-signal))) + (let* ((signal nil) + (wakeup 0)) + (without-interrupts + (%lock-futex ptr -1 lock nil) + (let* ((state (%get-signed-natural ptr target::rwlock.state)) + (tcr (%current-tcr))) + (declare (fixnum state tcr)) + (cond ((> state 0) + (unless (eql tcr (%get-object ptr target::rwlock.writer)) + (%unlock-futex ptr) + (error 'not-lock-owner :lock lock)) + (decf state)) + ((< state 0) (incf state)) + (t (%unlock-futex ptr) + (error 'not-locked :lock lock))) + (setf (%get-signed-natural ptr target::rwlock.state) state) + (when (zerop state) + (note-lock-released) + (setf (%get-signed-natural ptr target::rwlock.writer) 0) + (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) + (nreaders (%get-natural ptr target::rwlock.blocked-readers))) + (declare (fixnum nreaders nwriters)) + (if (> nwriters 0) + (setq signal writer-signal wakeup 1) + (if (> nreaders 0) + (setq signal reader-signal wakeup #$INT_MAX))))) + (when signal (incf (%get-signed-natural signal 0))) + (%unlock-futex ptr) + (when signal (futex-wake signal wakeup)) + t))))) + + +(defun unlock-rwlock (lock) + (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock)) + +;;; There are all kinds of ways to lose here. +;;; The caller must have read access to the lock exactly once, +;;; or have write access. +;;; there's currently no way to detect whether the caller has +;;; read access at all. +;;; If we have to block and get interrupted, cleanup code may +;;; try to unlock a lock that we don't hold. (It might be possible +;;; to circumvent that if we use the same notifcation object here +;;; that controls that cleanup process.) + +(defun %promote-rwlock (lock &optional flag) + (let* ((ptr (read-write-lock-ptr lock))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (without-interrupts + #+futex + (%lock-futex ptr level lock nil) + #-futex + (%get-spin-lock ptr) + (let* ((state (%get-signed-natural ptr target::rwlock.state))) + (declare (fixnum state)) + (cond ((> state 0) + (unless (eql (%get-object ptr target::rwlock.writer) tcr) + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (error :not-lock-owner :lock lock))) + ((= state 0) + #+futex (%unlock-futex ptr) + #-futex (setf (%get-natural ptr target::rwlock.spin) 0) + (error :not-locked :lock lock)) + (t + (if (= state -1) + (progn + (setf (%get-signed-natural ptr target::rwlock.state) 1) + (%set-object ptr target::rwlock.writer tcr) + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (progn + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (%unlock-rwlock-ptr ptr lock) + (let* ((*interrupt-level* level)) + (%write-lock-rwlock-ptr ptr lock flag))))))))))) + + (defun safe-get-ptr (p &optional dest) Index: /branches/event-ide/ccl/level-0/l0-numbers.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-numbers.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-numbers.lisp (revision 8262) @@ -1726,4 +1726,5 @@ +#+32-bit-target (defun random (number &optional (state *random-state*)) (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) @@ -1733,5 +1734,10 @@ (if (< number 65536) (fast-mod (%next-random-seed state) number) - (%bignum-random number state)))) + (let* ((n 0) + (nhalf (ash (+ 15 (integer-length number)) -4))) + (declare (fixnum n nhalf)) + (dotimes (i nhalf (fast-mod n number)) + (setq n (logior (the fixnum (ash n 16)) + (the fixnum (%next-random-seed state))))))))) ((and (typep number 'double-float) (> (the double-float number) 0.0)) (%float-random number state)) @@ -1742,4 +1748,24 @@ (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) +#+64-bit-target +(defun random (number &optional (state *random-state*)) + (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) + (cond + ((and (fixnump number) (> (the fixnum number) 0)) + (locally (declare (fixnum number)) + (let* ((n 0) + (n32 (ash (+ 31 (integer-length number)) -5))) + (declare (fixnum n n32)) + (dotimes (i n32 (fast-mod n number)) + (setq n (logior (the fixnum (ash n 32)) + (the fixnum (%next-random-seed state)))))))) + ((and (typep number 'double-float) (> (the double-float number) 0.0)) + (%float-random number state)) + ((and (typep number 'short-float) (> (the short-float number) 0.0s0)) + (%float-random number state)) + ((and (bignump number) (> number 0)) + (%bignum-random number state)) + (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) + #| @@ -1784,28 +1810,21 @@ #+64-bit-target -(defun %next-random-pair (high low) - (declare (type (unsigned-byte 16) high low)) - (let* ((n0 - (%i* 48271 - (the (unsigned-byte 31) - (logior (the (unsigned-byte 31) - (ash (ldb (byte 15 0) high) 16)) - (the (unsigned-byte 16) - (ldb (byte 16 0) low)))))) - (n (fast-mod n0 (1- (expt 2 31))))) +(defun %next-random-seed (state) + (let* ((n (the fixnum (* (the fixnum (random.seed-1 state)) 48271)))) (declare (fixnum n)) - (values (ldb (byte 15 16) n) - (ldb (byte 16 0) n)))) - + (setf (random.seed-1 state) (fast-mod n (1- (expt 2 31)))) + (logand n (1- (ash 1 32))))) + +#+32-bit-target (defun %next-random-seed (state) - (multiple-value-bind (high low) (%next-random-pair (%svref state 1) - (%svref state 2)) + (multiple-value-bind (high low) (%next-random-pair (random.seed-1 state) + (random.seed-2 state)) (declare (type (unsigned-byte 15) high) (type (unsigned-byte 16) low)) - (setf (%svref state 1) high - (%svref state 2) low) + (setf (random.seed-1 state) high + (random.seed-2 state) low) (logior high (the fixnum (logand low (ash 1 15)))))) - +#+32-bit-target (defun %bignum-random (number state) (let* ((bits (+ (integer-length number) 8)) @@ -1836,9 +1855,7 @@ (defun %float-random (number state) - (if (zerop number) - number - (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum))) - (declare (dynamic-extent ratio)) - (* number ratio)))) + (let ((ratio (gvector :ratio (random most-positive-fixnum state) most-positive-fixnum))) + (declare (dynamic-extent ratio)) + (* number ratio))) (eval-when (:compile-toplevel :execute) Index: /branches/event-ide/ccl/level-0/l0-pred.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-pred.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-pred.lisp (revision 8262) @@ -28,19 +28,19 @@ (defun find-class-cell (type create?) (declare (ignore create?)) - (cons type nil)) + (make-class-cell type)) (defun builtin-typep (form cell) - (typep form (car cell))) + (typep form (class-cell-name cell))) (defun class-cell-typep (arg class-cell) - (typep arg (car class-cell))) + (typep arg (class-cell-name class-cell))) (defun class-cell-find-class (class-cell errorp) (declare (ignore errorp)) ; AARGH can't be right ;(dbg-paws #x100) - (let ((class (cdr class-cell))) + (let ((class (and class-cell (class-cell-class class-cell)))) (or class (if (fboundp 'find-class) - (find-class (car class-cell) nil))))) + (find-class (class-cell-name class-cell) nil))))) (defun %require-type-builtin (form foo) @@ -401,5 +401,5 @@ catch-frame ; 4 function ; 5 - lisp-thread ; 6 + basic-stream ; 6 symbol ; 7 lock ; 8 @@ -586,5 +586,5 @@ ratio symbol - lisp-thread + basic-stream standard-instance complex @@ -703,5 +703,5 @@ package slot-vector - lisp-thread + basic-stream function-vector ;8 array-header Index: /branches/event-ide/ccl/level-0/l0-symbol.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-symbol.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-symbol.lisp (revision 8262) @@ -48,8 +48,17 @@ ;;; The type-checking done on the "plist" arg shouldn't be removed. (defun set-symbol-plist (sym plist) - (let* ((len (list-length plist))) - (unless (and len (evenp len)) - (error "Bad plist: ~s" plist))) - (setf (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell) plist)) + (when plist + (let* ((len (list-length plist))) + (unless (and len (evenp len)) + (error "Bad plist: ~s" plist)))) + (let* ((vector (symptr->symvector (%symbol->symptr sym))) + (cell (%svref vector target::symbol.plist-cell))) + (if plist + (if (consp cell) + (setf (cdr cell) plist) + (cdr (setf (%svref vector target::symbol.plist-cell) (cons nil plist)))) + (if (car cell) + (setf (cdr cell) nil) + (if cell (setf (cdr cell) nil)))))) @@ -70,5 +79,5 @@ (defun symbol-plist (sym) "Return SYMBOL's property list." - (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)) + (cdr (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell))) @@ -77,14 +86,20 @@ is found, return the associated value, else return DEFAULT." (let* ((tail (%pl-search - (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell) key))) + (cdr (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)) key))) (if tail (%cadr tail) default))) (defun put (sym key value) (let* ((symptr (%symbol->symptr sym)) - (plist (%svref (symptr->symvector symptr) target::symbol.plist-cell)) + (vector (symptr->symvector symptr)) + (cell (%svref vector target::symbol.plist-cell)) + (plist (cdr cell)) (tail (%pl-search plist key))) (if tail (%rplaca (%cdr tail) value) - (setf (%svref (symptr->symvector symptr) target::symbol.plist-cell) (cons key (cons value plist)))) + (progn + (setq plist (cons key (cons value plist))) + (if cell + (setf (cdr cell) plist) + (setf (%svref vector target::symbol.plist-cell) (cons nil plist))))) value)) Index: /branches/event-ide/ccl/level-0/l0-utils.lisp =================================================================== --- /branches/event-ide/ccl/level-0/l0-utils.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/l0-utils.lisp (revision 8262) @@ -107,4 +107,11 @@ (assq item list))) +(defun assequal (item list) + (dolist (pair list) + (if pair + (if (equal item (car pair)) + (return pair))))) + + ;;; (memeql item list) <=> (member item list :test #'eql :key #'identity) (defun memeql (item list) @@ -113,6 +120,10 @@ ((endp l)) (when (eql (%car l) item) (return l))) - (memq item list)) -) + (memq item list))) + +(defun memequal (item list) + (do* ((l list (%cdr l))) + ((endp l)) + (when (equal (%car l) item) (return l)))) Index: /branches/event-ide/ccl/level-0/nfasload.lisp =================================================================== --- /branches/event-ide/ccl/level-0/nfasload.lisp (revision 8261) +++ /branches/event-ide/ccl/level-0/nfasload.lisp (revision 8262) @@ -1045,5 +1045,5 @@ *xload-startup-file*)) (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot. - + (setq %system-locks% (%cons-population nil)) ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually ;; do SET-PACKAGE in cold load functions. Index: /branches/event-ide/ccl/level-1/l1-aprims.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-aprims.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-aprims.lisp (revision 8262) @@ -44,5 +44,13 @@ (def-standard-initial-binding *gensym-counter* 0) (def-standard-initial-binding *random-state* (initialize-random-state #xFBF1 9)) - +#+lock-accounting +(progn +(def-standard-initial-binding *locks-held* ()) +(def-standard-initial-binding *locks-pending* ()) +(def-standard-initial-binding *lock-conses* (make-list 20))) +(def-standard-initial-binding *whostate* "Reset") +(setq *whostate* "Active") +(def-standard-initial-binding *error-print-length* 20) +(def-standard-initial-binding *error-print-level* 8) (defun %badarg (arg type) @@ -124,13 +132,5 @@ -(defun make-list (size &key initial-element) - "Constructs a list with size elements each set to value" - (unless (and (typep size 'fixnum) - (>= (the fixnum size) 0)) - (report-bad-arg size '(and fixnum unsigned-byte))) - (locally (declare (fixnum size)) - (do* ((result '() (cons initial-element result))) - ((zerop size) result) - (decf size)))) + @@ -234,10 +234,19 @@ (defvar %setf-function-names% (make-hash-table :weak t :test 'eq)) +(defvar %setf-function-name-inverses% (make-hash-table :weak t :test 'eq)) (defun setf-function-name (sym) (or (gethash sym %setf-function-names%) - (setf (gethash sym %setf-function-names%) (construct-setf-function-name sym)))) - - + (progn + (let* ((setf-package-sym (construct-setf-function-name sym))) + (setf (gethash setf-package-sym %setf-function-name-inverses%) sym + (gethash sym %setf-function-names%) setf-package-sym))))) + + +(defun maybe-setf-name (sym) + (let* ((other (gethash sym %setf-function-name-inverses%))) + (if other + `(setf ,other) + sym))) @@ -252,5 +261,5 @@ (values (intern - ;I wonder, if we didn't check, would anybody report it as a bug? + ;;I wonder, if we didn't check, would anybody report it as a bug? (if (not (%str-member #\: (setq pkg (package-name pkg)))) (%str-cat pkg "::" sym) @@ -1861,4 +1870,7 @@ (gethash lower *non-standard-lower-to-upper*) upper))) +(assert-hash-table-readonly *non-standard-upper-to-lower*) +(assert-hash-table-readonly *non-standard-lower-to-upper*) + (defun %non-standard-upper-case-equivalent (char) (gethash char *non-standard-lower-to-upper*)) Index: /branches/event-ide/ccl/level-1/l1-boot-1.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-boot-1.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-boot-1.lisp (revision 8262) @@ -96,4 +96,7 @@ trans)))) +(defun set-ccl-directory (path) + (replace-base-translation "ccl:" (translate-logical-pathname path))) + Index: /branches/event-ide/ccl/level-1/l1-boot-2.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-boot-2.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-boot-2.lisp (revision 8262) @@ -269,5 +269,4 @@ (bin-load-provide "MCL-COMPAT" "mcl-compat") (require "LOOP") - (require "HASH-CONS") (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms") (l1-load-provide "VERSION" "version") Index: /branches/event-ide/ccl/level-1/l1-clos-boot.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-clos-boot.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-clos-boot.lisp (revision 8262) @@ -920,5 +920,5 @@ (unless found (return)) (when (cdr cell) - (funcall function name (cdr cell))))))) + (funcall function name (class-cell-class cell))))))) @@ -1045,5 +1045,12 @@ - +(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument. The dcode functions will be caled with all of the incoming arguments.") + +(defun non-dt-dcode-function (gf) + (dolist (f *non-dt-dcode-functions*) + (let* ((dcode (funcall f gf))) + (when dcode (return dcode))))) + + (defparameter dcode-proto-alist (list (cons #'%%one-arg-dcode *gf-proto-one-arg*) @@ -1074,15 +1081,17 @@ (if (or (null min-index) (< index min-index)) (setq min-index index)))))) - (let ((dcode (if 0-args? - #'%%0-arg-dcode - (or (if multi-method-index - #'%%nth-arg-dcode) - (if (null other-args?) - (if (eql nreq 1) - #'%%one-arg-dcode - (if (eql nreq 2) - #'%%1st-two-arg-dcode - #'%%1st-arg-dcode)) - #'%%1st-arg-dcode))))) + (let* ((non-dt (non-dt-dcode-function gf)) + (dcode (or non-dt + (if 0-args? + #'%%0-arg-dcode + (or (if multi-method-index + #'%%nth-arg-dcode) + (if (null other-args?) + (if (eql nreq 1) + #'%%one-arg-dcode + (if (eql nreq 2) + #'%%1st-two-arg-dcode + #'%%1st-arg-dcode)) + #'%%1st-arg-dcode)))))) (setq multi-method-index (if multi-method-index @@ -1096,7 +1105,9 @@ (function-name (%combined-method-dcode old-dcode))) (cdr (%combined-method-methods old-dcode))))) - (when (or (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode)) + (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode)) (neq multi-method-index (%gf-dispatch-table-argnum dt))) - (let ((proto (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*))) + (let* ((proto (if non-dt + #'funcallable-trampoline + (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*)))) (clear-gf-dispatch-table dt) (setf (%gf-dispatch-table-argnum dt) multi-method-index) @@ -1173,4 +1184,6 @@ + + ;;;;;;;;;;;;;;;;;;;;;;;; Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1179,24 +1192,24 @@ (defun class-cell-typep (form class-cell) - (unless (listp class-cell)(error "puke")) - (locally (declare (type list class-cell)) - (let ((class (cdr class-cell))) - (when (not class) - (setq class (find-class (car class-cell) nil)) - (when class (rplacd class-cell class))) - (if class - (not (null (memq class (%inited-class-cpl (class-of form))))) - (if (fboundp 'typep)(typep form (car class-cell)) t))))) + (locally (declare (type class-cell class-cell)) + (let ((class (class-cell-class class-cell))) + (loop + (if class + (let* ((wrapper (if (%standard-instance-p form) + (instance.class-wrapper form) + (instance-class-wrapper form)))) + (return + (not (null (memq class (or (%wrapper-cpl wrapper) + (%inited-class-cpl (%wrapper-class wrapper)))))))) + (if (setq class (find-class (class-cell-name class-cell) nil)) + (setf (class-cell-class class-cell) class) + (return (typep form (class-cell-name class-cell))))))))) (defun %require-type-class-cell (arg class-cell) - ; sort of weird - (if (or ;(not *type-system-initialized*) - (not (listp class-cell))) ; bootstrapping prob no longer - arg ; (progn (pushnew class-cell puke) arg) - (if (class-cell-typep arg class-cell) - arg - (%kernel-restart $xwrongtype arg (car class-cell))))) + (if (class-cell-typep arg class-cell) + arg + (%kernel-restart $xwrongtype arg (car class-cell)))) @@ -1206,11 +1219,11 @@ (or cell (and create? - (setf (gethash name %find-classes%) (cons name nil)))))) + (setf (gethash name %find-classes%) (make-class-cell name)))))) (defun find-class (name &optional (errorp t) environment) (let* ((cell (find-class-cell name nil))) - (declare (list cell)) - (or (cdr cell) + (declare (type class-cell cell)) + (or (and cell (class-cell-class cell)) (let ((defenv (and environment (definition-environment environment)))) (when defenv @@ -1227,5 +1240,5 @@ (if (eq name (%class.name class)) (setf (info-type-kind name) :instance)) - (setf (cdr (the cons cell)) class)) + (setf (class-cell-class cell) class)) class)) @@ -1248,4 +1261,14 @@ (defenv.classes defenv))))) name) + +(eval-when (:compile-toplevel :execute) +(declaim (inline standard-instance-p)) +) + + + + +(defun standard-instance-p (i) + (eq (typecode i) target::subtag-instance)) (defun check-setf-find-class-protected-class (old-class new-class name) @@ -1266,6 +1289,6 @@ (setq name (require-type name 'symbol)) (let ((cell (find-class-cell name class))) - (declare (type list cell)) - (let ((old-class (cdr cell))) + (declare (type class-cell cell)) + (let ((old-class (class-cell-class cell))) (when old-class (when (eq (%class.name old-class) name) @@ -1276,9 +1299,9 @@ (when (null class) (when cell - (setf (cdr cell) nil)) + (setf (class-cell-class cell) nil)) (return-from set-find-class nil)) (setq class (require-type class 'class)) (when (built-in-type-p name) - (unless (eq (cdr cell) class) + (unless (eq (class-cell-class cell) class) (error "Cannot redefine built-in type name ~S" name))) (when (eq (%class.name class) name) @@ -1289,10 +1312,10 @@ (%deftype name nil nil)) (setf (info-type-kind name) :instance)) - (setf (cdr cell) class))) + (setf (class-cell-class cell) class))) ) ; end of queue-fixup -#| +#|| ; This tended to cluster entries in gf dispatch tables too much. (defvar *class-wrapper-hash-index* 0) @@ -1305,5 +1328,5 @@ (%i+ index 3) ; '3 = 24 bytes = 6 longwords in lap. 1)))) -|# +||# @@ -1316,8 +1339,10 @@ -(defvar *t-class* (let ((class (%cons-built-in-class 't))) - (setf (%class.cpl class) (list class)) - (setf (%class.own-wrapper class) - (%cons-wrapper class (new-class-wrapper-hash-index))) +(defvar *t-class* (let* ((class (%cons-built-in-class 't)) + (wrapper (%cons-wrapper class (new-class-wrapper-hash-index))) + (cpl (list class))) + (setf (%class.cpl class) cpl) + (setf (%wrapper-cpl wrapper) cpl) + (setf (%class.own-wrapper class) wrapper) (setf (%class.ctype class) (make-class-ctype class)) (setf (find-class 't) class) @@ -1376,6 +1401,9 @@ (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) (setf (%class.local-supers class) supers) - (setf (%class.cpl class) (compute-cpl class)) - (setf (%class.own-wrapper class) (%cons-wrapper class (new-class-wrapper-hash-index))) + (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index))) + (cpl (compute-cpl class))) + (setf (%class.cpl class) cpl) + (setf (%class.own-wrapper class) wrapper) + (setf (%wrapper-cpl wrapper) cpl)) (setf (%class.ctype class) (make-class-ctype class)) (setf (find-class name) class) @@ -1415,10 +1443,10 @@ (%cons-wrapper class)))) (setf (%class.cpl class) cpl - (%wrapper-instance-slots wrapper) (vector) + (%wrapper-instance-slots wrapper) (vector) (%class.own-wrapper class) wrapper (%class.ctype class) (make-class-ctype class) (%class.slots class) nil - (find-class name) class - ) + (%wrapper-cpl wrapper) cpl + (find-class name) class) (dolist (sup supers) (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) @@ -1426,13 +1454,4 @@ -(eval-when (:compile-toplevel :execute) -(declaim (inline standard-instance-p)) -) - - - - -(defun standard-instance-p (i) - (eq (typecode i) target::subtag-instance)) @@ -1683,5 +1702,5 @@ (make-built-in-class 'intersection-ctype *ctype-class*) - + (make-built-in-class 'class-cell *istruct-class*) (make-built-in-class 'complex (find-class 'number)) (make-built-in-class 'real (find-class 'number)) @@ -1782,15 +1801,15 @@ (defun class-cell-find-class (class-cell errorp) - (unless (listp class-cell) - (setq class-cell (%kernel-restart $xwrongtype class-cell 'list))) - (locally (declare (type list class-cell)) - (let ((class (cdr class-cell))) + (unless (istruct-typep class-cell 'class-cell) + (setq class-cell (%kernel-restart $xwrongtype class-cell 'class-cell))) + (locally (declare (type class-cell class-cell)) + (let ((class (class-cell-class class-cell))) (or class (and - (setq class (find-class (car class-cell) nil)) + (setq class (find-class (class-cell-name class-cell) nil)) (when class - (rplacd class-cell class) + (setf (class-cell-class class-cell) class) class)) - (if errorp (error "Class ~s not found." (car class-cell)) nil))))) + (if errorp (error "Class ~s not found." (class-cell-name class-cell)) nil))))) ;;; (%wrapper-class (instance.class-wrapper frob)) @@ -2396,5 +2415,5 @@ (declare (dynamic-extent initargs)) (apply #'make-instance - (or (cdr class-cell) (car (the list class-cell))) + (or (class-cell-class class-cell) (class-cell-name (the class-cell class-cell))) initargs)) @@ -2528,4 +2547,5 @@ (type-predicate (standard-effective-slot-definition.type-predicate slotd))) (unless (or (eq new (%slot-unbound-marker)) + (null type-predicate) (funcall type-predicate new)) (error 'bad-slot-type @@ -2756,4 +2776,5 @@ (when forwarding-info (setf (%wrapper-hash-index wrapper) 0 + (%wrapper-cpl wrapper) nil (%wrapper-instance-slots wrapper) 0 (%wrapper-forwarding-info wrapper) forwarding-info @@ -3435,9 +3456,13 @@ (setf (fdefinition '%do-remove-direct-method) #'remove-direct-method) +(defmethod instance-class-wrapper (x) + (%class.own-wrapper (class-of x))) + (defmethod instance-class-wrapper ((instance standard-object)) (if (%standard-instance-p instance) (instance.class-wrapper instance) (if (typep instance 'macptr) - (foreign-instance-class-wrapper instance)))) + (foreign-instance-class-wrapper instance) + (%class.own-wrapper (class-of instance))))) (defmethod instance-class-wrapper ((instance standard-generic-function)) Index: /branches/event-ide/ccl/level-1/l1-clos.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-clos.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-clos.lisp (revision 8262) @@ -548,5 +548,6 @@ (setf (%class.cpl class) cpl) #|(force-cache-flushes class)|#) - (setf (%class.cpl class) cpl))) + (setf (%class.cpl class) cpl)) + cpl) @@ -599,10 +600,12 @@ (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) - (update-cpl class (compute-class-precedence-list class)) - ;;; This -should- be made to work for structure classes - (update-slots class (compute-slots class)) - (setf (%class-default-initargs class) (compute-default-initargs class)) - (%flush-initargs-caches class) - ) + (let* ((cpl (update-cpl class (compute-class-precedence-list class)))) + ;; This -should- be made to work for structure classes + (update-slots class (compute-slots class)) + (setf (%class-default-initargs class) (compute-default-initargs class)) + (%flush-initargs-caches class) + (let* ((wrapper (%class-own-wrapper class))) + (when wrapper + (setf (%wrapper-cpl wrapper) cpl))))) (unless finalizep (dolist (sub (%class-direct-subclasses class)) @@ -1096,4 +1099,5 @@ :initfunction ,#'false :readers (slot-definition-writers)))) + (%ensure-class-preserving-wrapper 'effective-slot-definition @@ -1103,6 +1107,6 @@ (:name slot-id :initform nil :initfunction ,#'false :readers (slot-definition-slot-id)) - (:name type-predicate :initform #'true - :initfunction ,#'(lambda () #'true) + (:name type-predicate :initform nil + :initfunction ,#'false :readers (slot-definition-predicate)) ) @@ -1125,4 +1129,5 @@ :direct-superclasses '(standard-slot-definition direct-slot-definition) ) + (%ensure-class-preserving-wrapper @@ -1192,7 +1197,8 @@ (add-direct-subclass c class))) (setf (%class.local-supers class) new-supers))) - (unless (%class-own-wrapper class) - (setf (%class-own-wrapper class) (%cons-wrapper class))) - (update-cpl class (compute-cpl class)))) + (let* ((wrapper (or (%class-own-wrapper class) + (setf (%class-own-wrapper class) (%cons-wrapper class)))) + (cpl (compute-cpl class))) + (setf (%wrapper-cpl wrapper) cpl)))) @@ -1571,5 +1577,5 @@ (logior (ash 1 $lfbits-gfn-bit) (ash 1 $lfbits-aok-bit))))) - (setf (gf.hash fn) (strip-tag-to-fixnum fn) + (setf (slot-vector.instance slots) fn) (when dt @@ -1620,4 +1626,9 @@ (declare (ignore env)) `(ensure-slot-id ,(slot-id.name s))) + +(defmethod make-load-form ((c class-cell) &optional env) + (declare (ignore env)) + `(find-class-cell ,(class-cell-name c))) + @@ -1688,5 +1699,7 @@ ;; obsolete instances. This'll eventually call ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to. - (let* ((wrapper (instance-class-wrapper instance)) + (let* ((wrapper (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance) + (instance-class-wrapper instance))) (class (%wrapper-class wrapper))) (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete @@ -1709,5 +1722,6 @@ ;; Typecheck the new-value, then call ;; (SETF SLOT-VALUE-USING-CLASS) - (unless (funcall predicate new-value) + (unless (or (null predicate) + (funcall predicate new-value)) (error 'bad-slot-type-from-initarg :slot-definition slotd @@ -1729,5 +1743,6 @@ (if initfunction (let* ((newval (funcall initfunction))) - (unless (funcall predicate newval) + (unless (or (null predicate) + (funcall predicate newval)) (error 'bad-slot-type-from-initform :slot-definition slotd @@ -1738,2 +1753,543 @@ newval)))))))))) instance) + +;;; Sometimes you can do a lot better at generic function dispatch than the +;;; default. This supports that for the one-arg-dcode case. +(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t)) + nil) + +(defun optimize-generic-function-dispatching () + (dolist (gf (population.data %all-gfs%)) + (optimize-dispatching-for-gf gf))) + +(defun optimize-dispatching-for-gf (gf) + (let* ((dcode (%gf-dcode gf))) + (when (or (eq dcode #'%%one-arg-dcode) + (eq dcode #'%%nth-arg-dcode)) + (let ((methods (generic-function-methods gf))) + (when (and methods (null (cdr methods))) + (when (or (eq #'%%one-arg-dcode dcode) + (and (eq #'%%nth-arg-dcode dcode) + (let ((spec (method-specializers (car methods))) + (argnum (%gf-dispatch-table-argnum + (%gf-dispatch-table gf)))) + (and (eql 2 (length spec)) + (and (eql argnum 1) (eq (car spec) *t-class*)))))) + (override-one-method-one-arg-dcode gf (car methods)))))))) + +;;; dcode for a GF with a single reader method which accesses +;;; a slot in a class that has no subclasses (that restriction +;;; makes typechecking simpler and also ensures that the slot's +;;; location is correct.) +(defun singleton-reader-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((class (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data)))) + (if (eq (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + class) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +(defun reader-constant-location-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((classes (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data)))) + (if (memq (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + classes) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +;;; The number of classes is for which the method is applicable is +;;; large, but all are subclasses of a single class +(defun reader-constant-location-inherited-from-single-class-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((defining-class (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data))) + (class (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)))) + (if (and class (memq defining-class (or (%class.cpl class) + (%inited-class-cpl class)))) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +;;; The number of classes is for which the method is applicable is +;;; large, but all are subclasses of one of a (small) set of defining classes. +(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((location (%svref dt (1+ %gf-dispatch-table-first-data))) + (class (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance))) + (cpl (if class (or (%class.cpl class) (%inited-class-cpl class))))) + (if (dolist (defining-class (%svref dt %gf-dispatch-table-first-data)) + (when (memq defining-class cpl) (return t))) + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + + +;;; Similar to the case above, but we use an alist to map classes +;;; to their non-constant locations. +(defun reader-variable-location-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((alist (%svref dt %gf-dispatch-table-first-data)) + (location (cdr + (assq + (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + alist)))) + (if location + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) + +(defun class-and-slot-location-alist (classes slot-name) + (let* ((alist nil)) + (labels ((add-class (c) + (unless (assq c alist) + (let* ((slots (class-slots c))) + (unless slots + (finalize-inheritance c) + (setq slots (class-slots c))) + (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist)) + (dolist (sub (class-direct-subclasses c)) + (add-class sub))))) + (dolist (class classes) (add-class class)) + ;; Building the alist the way that we have should often approximate + ;; this ordering; the idea is that leaf classes are more likely to + ;; be instantiated than non-leaves. + (sort alist (lambda (c1 c2) + (< (length (class-direct-subclasses c1)) + (length (class-direct-subclasses c2)))) + :key #'car)))) + +;;; Return a list of all classes in CLASS-LIST that aren't subclasses +;;; of any other class in the list. +(defun remove-subclasses-from-class-list (class-list) + (if (null (cdr class-list)) + class-list + (collect ((unique)) + (dolist (class class-list (unique)) + (when (dolist (other class-list t) + (unless (eq class other) + (when (subtypep class other) (return nil)))) + (unique class)))))) + +;;; Try to replace gf dispatch with something faster in f. +(defun %snap-reader-method (f) + (when (slot-boundp f 'methods) + (let* ((methods (generic-function-methods f))) + (when (and methods + (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods) + (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods) + (every (lambda (m) (null (method-qualifiers m))) methods)) + (let* ((m0 (car methods)) + (name (slot-definition-name (accessor-method-slot-definition m0)))) + (when (every (lambda (m) + (eq name (slot-definition-name (accessor-method-slot-definition m)))) + (cdr methods)) + ;; All methods are *STANDARD-READER-METHODS* that + ;; access the same slot name. Build an alist of + ;; mapping all subclasses of all classes on which those + ;; methods are specialized to the effective slot's + ;; location in that subclass. + (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m))) + methods)) + (alist (class-and-slot-location-alist classes name)) + (loc (cdar alist)) + (dt (gf.dispatch-table f))) + ;; Only try to handle the case where all slots have + ;; :allocation :instance (and all locations - the CDRs + ;; of the alist pairs - are small, positive fixnums. + (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist) + (clear-gf-dispatch-table dt) + (cond ((null (cdr alist)) + ;; Method is only applicable to a single class. + (destructuring-bind (class . location) (car alist) + (setf (%svref dt %gf-dispatch-table-first-data) class + (%svref dt (1+ %gf-dispatch-table-first-data)) location + (gf.dcode f) #'singleton-reader-dcode))) + ((dolist (other (cdr alist) t) + (unless (eq (cdr other) loc) + (return))) + ;; All classes have the slot in the same location, + ;; by luck or design. + (cond + ((< (length alist) 10) + ;; Only a small number of classes, just do MEMQ + (setf (%svref dt %gf-dispatch-table-first-data) + (mapcar #'car alist) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) #'reader-constant-location-dcode)) + ((null (cdr (setq classes (remove-subclasses-from-class-list classes)))) + ;; Lots of classes, all subclasses of a single class + (setf (%svref dt %gf-dispatch-table-first-data) + (car classes) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) + #'reader-constant-location-inherited-from-single-class-dcode)) + (t + ;; Multple classes. We should probably check + ;; to see they're disjoint + (setf (%svref dt %gf-dispatch-table-first-data) + classes + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) + #'reader-constant-location-inherited-from-multiple-classes-dcode)))) + (t + ;; Multiple classes; the slot's location varies. + (setf (%svref dt %gf-dispatch-table-first-data) + alist + + (gf.dcode f) #'reader-variable-location-dcode))))))))))) + +;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T) +;;; specializers are all EQL specializers whose objects are symbols. +;;; The effective method applicable for each symbol is stored on the +;;; plist of the symbol under a property EQ to the dispatch table (which +;;; is mostly ignored, otherwise.) +(defun %%1st-arg-eql-method-hack-dcode (dt args) + (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0))) + (mf (if (symbolp sym) (get sym dt)))) + (if mf + (if (listp args) + (apply mf args) + (%apply-lexpr-tail-wise mf args)) + ;;; Let %%1st-arg-dcode deal with it. + (%%1st-arg-dcode dt args)))) + +(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2) + (let* ((mf (if (typep arg1 'symbol) (get arg1 dt)))) + (if mf + (funcall mf arg1 arg2) + (%%1st-two-arg-dcode dt arg1 arg2)))) + +(defun %%one-arg-eql-method-hack-dcode (dt arg) + (let* ((mf (if (typep arg 'symbol) (get arg dt)))) + (if mf + (funcall mf arg)))) + +(defun install-eql-method-hack-dcode (gf) + (let* ((bits (inner-lfun-bits gf)) + (nreq (ldb $lfbits-numreq bits)) + (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits))) + (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (logbitp $lfbits-aok-bit bits)))) + (setf (%gf-dcode gf) + (cond ((and (eql nreq 1) (null other-args?)) + #'%%one-arg-eql-method-hack-dcode) + ((and (eql nreq 2) (null other-args?)) + #'%%1st-two-arg-eql-method-hack-dcode) + (t + #'%%1st-arg-eql-method-hack-dcode))))) + + + + + +(defun maybe-hack-eql-methods (gf) + (let* ((methods (generic-function-methods gf))) + (when (and methods + (every #'(lambda (method) + (let* ((specializers (method-specializers method)) + (first (car specializers))) + (and (typep first 'eql-specializer) + (typep (eql-specializer-object first) 'symbol) + (dolist (s (cdr specializers) t) + (unless (eq s *t-class*) + (return nil))) + (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers)))))))))) + methods)) + (let* ((dt (%gf-dispatch-table gf))) + (dolist (m methods) + (let* ((sym (eql-specializer-object (car (method-specializers m)))) + (f (method-function m))) + (setf (get sym dt) f))) + (install-eql-method-hack-dcode gf) + t)))) + + + + +;;; Return a list of :after methods for INITIALIZE-INSTANCE on the +;;; class's prototype, and a boolean that's true if no other qualified +;;; methods are defined. +(defun initialize-instance-after-methods (proto class) + (let* ((method-list (compute-method-list (sort-methods + (compute-applicable-methods #'initialize-instance (list proto)) + (list (class-precedence-list class)))))) + (if (atom method-list) + (values nil t) + (if (null (car method-list)) + (values (cadr method-list) t) + ;; :around or :before methods, give up + (values nil nil))))) + +(defparameter *typecheck-slots-in-optimized-make-instance* t) + + +;;; Return a lambda form or NIL. +(defun make-instantiate-lambda-for-class-cell (cell) + (let* ((class (class-cell-class cell)) + (after-methods nil)) + (when (and (typep class 'standard-class) + (progn (unless (class-finalized-p class) + (finalize-inheritance class)) + t) + (null (cdr (compute-applicable-methods #'allocate-instance (list class)))) + (let* ((proto (class-prototype class))) + (and (multiple-value-bind (afters ok) + (initialize-instance-after-methods proto class) + (when ok + (setq after-methods afters) + t)) + (null (cdr (compute-applicable-methods #'shared-initialize (list proto t))))))) + (let* ((slotds (sort (copy-list (class-slots class)) + #'(lambda (x y) + (if (consp x) x (if (consp y) y (< x y)))) + :key #'slot-definition-location)) + (default-initargs (class-default-initargs class))) + (collect ((keys) + (binds) + (class-binds) + (ignorable) + (class-slot-inits) + (after-method-forms) + (forms)) + (flet ((generate-type-check (form type &optional spvar) + (if (or (null *typecheck-slots-in-optimized-make-instance*) + (eq type t) + (and (quoted-form-p type) (eq (cadr type) t))) + form + (if spvar + `(if ,spvar + (require-type ,form ',type) + ,form) + `(require-type ,form ',type))))) + (dolist (slot slotds) + (let* ((initargs (slot-definition-initargs slot)) + (initfunction (slot-definition-initfunction slot)) + (initform (slot-definition-initform slot)) + (location (slot-definition-location slot)) + (location-var nil) + (one-initarg-p (null (cdr initargs))) + (name (slot-definition-name slot)) + (type (slot-definition-type slot))) + (when (consp location) + (setq location-var (gensym "LOCATION")) + (class-binds `(,location-var + (load-time-value + (slot-definition-location ',slot))))) + (when initfunction + (setq initform + (if (self-evaluating-p initform) + initform + `(funcall ,initfunction)))) + (cond ((null initargs) + (let ((initial-value-form + (if initfunction + (generate-type-check initform type) + `(%slot-unbound-marker)))) + (if (consp location) + (when initfunction + (class-slot-inits + `(when (eq (%slot-unbound-marker) (cdr ,location-var)) + (setf (cdr ,location-var) ,initial-value-form)))) + (forms initial-value-form)))) + (t (collect ((cond-clauses)) + (let ((last-cond-clause nil)) + (dolist (initarg initargs) + (let* ((spvar nil) + (name (if one-initarg-p + name + (gensym (string name)))) + (initial-value-form + (if (and initfunction + one-initarg-p + (atom location)) + initform + (progn + (when initarg + (setq spvar (make-symbol + (concatenate + 'string + (string initarg) + "-P")))) + (and one-initarg-p + (atom location) + (if initfunction + initform + `(%slot-unbound-marker)))))) + (default (assq initarg default-initargs))) + (when spvar (ignorable spvar)) + (when default + (destructuring-bind (form function) + (cdr default) + (setq default + (if (self-evaluating-p form) + form + `(funcall ,function))))) + (keys (list* + (list initarg name) + (if (and default one-initarg-p (atom location)) + default + initial-value-form) + (if spvar (list spvar)))) + (if one-initarg-p + (if (consp location) + (class-slot-inits + `(if ,spvar + (setf (cdr ,location-var) + ,(generate-type-check + name type)) + ,(if default + `(setf (cdr ,location-var) + ,(generate-type-check + default type)) + (when initfunction + `(when (eq (%slot-unbound-marker) + (cdr ,location-var)) + (setf (cdr ,location-var) + ,(generate-type-check + initform type))))))) + (forms `,(generate-type-check name type spvar))) + (progn (cond-clauses `(,spvar ,name)) + (when (and default (null last-cond-clause)) + (setq last-cond-clause + `(t ,default))))))) + (when (cond-clauses) + (when last-cond-clause + (cond-clauses last-cond-clause)) + (cond ((atom location) + (unless last-cond-clause + (cond-clauses `(t ,initform))) + (forms (generate-type-check + `(cond ,@(cond-clauses)) + type))) + (t + (let ((initform-p-var + (unless last-cond-clause + (make-symbol "INITFORM-P"))) + (value-var (make-symbol "VALUE"))) + (unless last-cond-clause + (cond-clauses + `(t (setq ,initform-p-var t) + ,(if initfunction + initform + `(%slot-unbound-marker))))) + (class-slot-inits + `(let* (,@(and initform-p-var + (list `(,initform-p-var nil))) + (,value-var + ,(generate-type-check + `(cond ,@(cond-clauses)) type))) + (when + ,(if initform-p-var + `(or (null ,initform-p-var) + (and (eq (cdr ,location-var) + (%slot-unbound-marker)) + (not (eq ,value-var + (%slot-unbound-marker))))) + t) + (setf (cdr ,location-var) ,value-var))))))))))))))) + (let* ((cell (make-symbol "CLASS-CELL")) + (args (make-symbol "ARGS")) + (slots (make-symbol "SLOTS")) + (instance (make-symbol "INSTANCE"))) + (dolist (after after-methods) + (after-method-forms `(apply ,(method-function after) ,instance ,args))) + (when after-methods + (after-method-forms instance)) + (binds `(,slots (gvector :slot-vector nil ,@(forms)))) + (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots))) + `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys))) + (declare (ignorable ,@(ignorable))) + ,@(when after-methods `((declare (dynamic-extent ,args)))) + (let (,@(class-binds)) + ,@(class-slot-inits)) + (let* (,@(binds)) + (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance) + (%svref ,slots 0) ,instance) + ,@(after-method-forms))))))))) + +(defun optimize-make-instance-for-class-cell (cell) + (setf (class-cell-instantiate cell) '%make-instance) + (let* ((lambda (make-instantiate-lambda-for-class-cell cell))) + (when lambda + (setf (class-cell-instantiate cell) (compile nil lambda) + (class-cell-extra cell) (%class.own-wrapper + (class-cell-class cell))) + t))) + +(defun optimize-make-instance-for-class-name (class-name) + (optimize-make-instance-for-class-cell (find-class-cell class-name t))) + +(defun optimize-named-class-make-instance-methods () + (maphash (lambda (class-name class-cell) + (handler-case (optimize-make-instance-for-class-cell class-cell) + (error (c) + (warn "error optimizing make-instance for ~s:~&~a" + class-name c)))) + %find-classes%)) + +;;; Iterate over all known GFs; try to optimize their dcode in cases +;;; involving reader methods. + +(defun snap-reader-methods (&key known-sealed-world + (check-conflicts t) + (optimize-make-instance t)) + (declare (ignore check-conflicts)) + (unless known-sealed-world + (cerror "Proceed, if it's known that no new classes or methods will be defined." + "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined.")) + (when optimize-make-instance + (optimize-named-class-make-instance-methods)) + (let* ((ngf 0) + (nwin 0)) + (dolist (f (population.data %all-gfs%)) + (incf ngf) + (when (%snap-reader-method f) + (incf nwin))) + (values ngf nwin 0))) + +(defun register-non-dt-dcode-function (f) + (flet ((symbol-or-function-name (x) + (etypecase x + (symbol x) + (function (function-name x))))) + (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name))) + (if already + (setf (car already) f) + (push f *non-dt-dcode-functions*)) + f))) + +(defun dcode-for-universally-applicable-singleton (gf) + (let* ((methods (generic-function-methods gf)) + (method (car methods))) + (when (and method + (null (cdr methods)) + (null (method-qualifiers method)) + (dolist (spec (method-specializers method) t) + (unless (eq spec *t-class*) + (return nil)))) + (method-function method)))) + +(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton) + + + + + Index: /branches/event-ide/ccl/level-1/l1-dcode.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-dcode.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-dcode.lisp (revision 8262) @@ -186,8 +186,9 @@ Returns NIL - without storing anything - if the value already in DT at INDEX is non-NIL at the time of the store." - (%store-node-conditional (+ (ash (%i+ index %gf-dispatch-table-first-data) - target::word-shift) - target::misc-data-offset) - dt nil new)) + (let ((offset (+ (ash (%i+ index %gf-dispatch-table-first-data) + target::word-shift) + target::misc-data-offset))) + (or (%store-node-conditional offset dt nil new) + (%store-node-conditional offset dt *gf-dispatch-bug* new)))) (defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p) @@ -277,8 +278,4 @@ -; for calls from outside - e.g. stream-reader -(defun find-1st-arg-combined-method (gf arg) - (declare (optimize (speed 3)(safety 0))) - (%find-1st-arg-combined-method (%gf-dispatch-table gf) arg)) @@ -317,4 +314,10 @@ (setq flag 0 index -2))) (setq index (+ 2 index))))))))) + +;;; for calls from outside - e.g. stream-reader +(defun find-1st-arg-combined-method (gf arg) + (declare (optimize (speed 3)(safety 0))) + (%find-1st-arg-combined-method (%gf-dispatch-table gf) arg)) + ;;; more PC - it it possible one needs to go round more than once? - @@ -450,5 +453,5 @@ (%ilogior (%ilsl $lfbits-gfn-bit 1) (%ilogand $lfbits-args-mask 0))))) - (setf (gf.hash fn) (strip-tag-to-fixnum fn) + (setf ;(gf.hash fn) (strip-tag-to-fixnum fn) (slot-vector.instance slots) fn (%gf-dispatch-table-gf dt) fn) @@ -680,8 +683,5 @@ (setf contains-obsolete-wrappers-p t (%gf-dispatch-table-ref dt index) *obsolete-wrapper* - (%gf-dispatch-table-ref dt (1+ index)) - #'(lambda (&rest rest) - (declare (ignore rest)) - (error "Generic-function dispatch bug."))) + (%gf-dispatch-table-ref dt (1+ index)) *gf-dispatch-bug*) (setq count (%i+ count 1))))) (setq index (%i+ index 2))) @@ -786,8 +786,4 @@ -;;; arg passed is dispatch table - add a slot to it containing gf? - -;;; later or pass the gf instead of the dispatch table (means adding -;;; another constant to gf to contain the dispatch table- above is -;;; clearer) (defun %%1st-arg-dcode (dt args) @@ -856,9 +852,9 @@ (combined-method (compute-1st-arg-combined-method gf arg wrapper))) (multiple-value-bind (index obsolete-wrappers-p) - (find-gf-dispatch-table-index table wrapper) + (find-gf-dispatch-table-index table wrapper) (if index - (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) - (setf (%gf-dispatch-table-ref table index) wrapper)) - (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p))) + (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) + (setf (%gf-dispatch-table-ref table index) wrapper)) + (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p))) combined-method)) @@ -1251,8 +1247,8 @@ wrapper) (multiple-value-bind (index obsolete-wrappers-p) - ( find-gf-dispatch-table-index table wrapper) + (find-gf-dispatch-table-index table wrapper) (if index (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) - (setf (%gf-dispatch-table-ref table index) wrapper)) + (setf (%gf-dispatch-table-ref table index) wrapper)) (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p))) (if sub-dispatch? @@ -1338,7 +1334,45 @@ - -;;; This needs to be updated to use a linear search in a vector changing to -;;; a hash table when the number of entries crosses some threshold. +(defun compute-eql-combined-method-hash-table-threshold (&optional (iters 1000000) (max 200)) + (flet ((time-assq (cnt iters) + (let ((alist (loop for i from 1 to cnt collect (cons i i))) + (start-time (get-internal-run-time)) + (j 0) + res) + (declare (fixnum j)) + (dotimes (i iters) + (declare (fixnum i)) + (setq res (cdr (assq j alist))) + (when (>= (incf j) cnt) (setq j 0))) + (values (- (get-internal-run-time) start-time) res))) + (time-hash (cnt iters) + (let ((hash (make-hash-table :test 'eq)) + start-time + (j 0) + res) + (declare (fixnum j)) + (dotimes (i cnt) + (setf (gethash i hash) i)) + (assert-hash-table-readonly hash) + (setq start-time (get-internal-run-time)) + (dotimes (i iters) + (declare (fixnum i)) + (setq res (gethash i hash)) + (when (>= (incf j) cnt) (setq j 0))) + (values (- (get-internal-run-time) start-time) res)))) + (dotimes (i max) + (let ((time-assq (time-assq i iters)) + (time-hash (time-hash i iters))) + (format t "i: ~d, assq: ~d, hash: ~d~%" i time-assq time-hash) + (when (> time-assq time-hash) (return i)))))) + +;; Value computed on a dual-core 2.4 GHz AMD Opteron running FC3 +;; This isn't the result of compute-eql-combined-method-hash-table-threshold, +;; it's the value at which assq takes 3/4 the time of hash, which weights +;; towards the worst case of the eql method, not the average for uniform inputs. +(defparameter *eql-combined-method-hash-table-threshold* 45) + +;;; A vector might be a little faster than an alist, but the hash table case +;;; will speed up large numbers of methods. (defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional (method-combination *standard-method-combination*)) @@ -1410,12 +1444,18 @@ real-gf method-combination methods))))) (if eql-method-alist - (%cons-combined-method - gf (cons argnum (cons eql-method-alist default-method)) - (if can-use-eq? - #'%%assq-combined-method-dcode - #'%%assoc-combined-method-dcode)) + (if (> (length eql-method-alist) *eql-combined-method-hash-table-threshold*) + (let ((hash (make-hash-table :test (if can-use-eq? 'eq 'eql)))) + (dolist (pair eql-method-alist) + (setf (gethash (car pair) hash) (cdr pair))) + (assert-hash-table-readonly hash) + (%cons-combined-method + gf (cons argnum (cons hash default-method)) + #'%%hash-table-combined-method-dcode)) + (%cons-combined-method + gf (cons argnum (cons eql-method-alist default-method)) + (if can-use-eq? + #'%%assq-combined-method-dcode + #'%%assoc-combined-method-dcode))) default-method)))) - - @@ -1462,4 +1502,20 @@ (%apply-lexpr (cdr thing) args) (%apply-lexpr (cddr stuff) args)))))) + + +(defun %%hash-table-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-hash-table . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args))) + (apply (gethash arg (cadr stuff) (cddr stuff)) args))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum))) + (%apply-lexpr (gethash arg (cadr stuff) (cddr stuff)) args))))) @@ -1755,7 +1811,7 @@ (apply-with-method-context magic (%method.function (car next-methods)) args)))))) -; may be simpler to blow another cell so magic looks like -; (cnm-cm/nil next-methods . args) - done -; and also use first cell to mean heap-consed if itsa cons +;;; may be simpler to blow another cell so magic looks like +;;; (cnm-cm/nil next-methods . args) - done +;;; and also use first cell to mean heap-consed if itsa cons (defun %call-next-method-with-args (magic &rest args) Index: /branches/event-ide/ccl/level-1/l1-error-system.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-error-system.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-error-system.lisp (revision 8262) @@ -262,4 +262,14 @@ (format s "Current process ~s does not own lock ~s" *current-process* (slot-value c 'lock))))) + +(define-condition not-locked (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Lock ~s isn't locked." (slot-value c 'lock))))) + +(define-condition deadlock (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock))))) (define-condition package-error (error) @@ -358,5 +368,5 @@ (define-condition end-of-file (stream-error) () (:report (lambda (c s) - (format s "Unexpected end of file ~s" (stream-error-context c))))) + (format s "Unexpected end of file ~a" (stream-error-context c))))) (define-condition impossible-number (reader-error) ((token :initarg :token :reader impossible-number-token) @@ -372,5 +382,5 @@ (define-condition simple-stream-error (stream-error simple-condition) () (:report (lambda (c s) - (format s "Error ~s : ~&~a" (stream-error-context c) + (format s "~a : ~&~a" (stream-error-context c) (apply #'format nil @@ -442,9 +452,8 @@ (status :initform nil :initarg :status :reader arithmetic-error-status)) (:report (lambda (c s) - (format s "~S detected " - (type-of c)) + (format s "~S detected" (type-of c)) (let* ((operands (arithmetic-error-operands c))) (when operands - (format s "~&performing ~S on ~:S" + (format s "~&performing ~A on ~:S" (arithmetic-error-operation c) operands)))))) @@ -457,4 +466,11 @@ (define-condition floating-point-invalid-operation (arithmetic-error)) +(define-condition compiler-bug (simple-error) + () + (:report (lambda (c stream) + (format stream "Compiler bug or inconsistency:~%") + (apply #'format stream (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + (defun restartp (thing) (istruct-typep thing 'restart)) @@ -581,9 +597,7 @@ "Make an instance of a condition object using the specified initargs." (declare (dynamic-extent init-list)) - (let ((class (or (and (symbolp name) (find-class name nil)) - name))) - (if (condition-p (class-prototype class)) - (apply #'make-instance class init-list) - (error "~S is not a defined condition type name" name)))) + (if (subtypep name 'condition) + (apply #'make-instance name init-list) + (error "~S is not a defined condition type name" name))) (defmethod print-object ((c condition) stream) Index: /branches/event-ide/ccl/level-1/l1-files.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-files.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-files.lisp (revision 8262) @@ -193,10 +193,17 @@ (when (directory-pathname-p path) (return-from %create-file (probe-file-x path))) - (assert (or (eql if-exists :overwrite) (not (probe-file path))) () + (assert (or (eql if-exists :overwrite) + (null if-exists) + (not (probe-file path))) () "~s ~s not implemented yet" :if-exists if-exists) (let* ((unix-name (native-translated-namestring path)) - (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC)))) + (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC + (if (null if-exists) + #$O_EXCL + 0))))) (if (< fd 0) - (signal-file-error fd path) + (if (eql fd (- #$EEXIST)) ; #$O_EXCL was set and file exists + (return-from %create-file nil) + (signal-file-error fd path)) (fd-close fd)) (%realpath unix-name))) @@ -421,9 +428,9 @@ ((and dir default-dir (eq (car dir) :absolute) (eq (car default-dir) :absolute)) - ; maybe make it relative to defaults + ;; maybe make it relative to defaults (do ((p1 (cdr dir) (cdr p1)) (p2 (cdr default-dir) (cdr p2))) ((or (null p2) (null p1) (not (equalp (car p1) (car p2)))) - (when (and (null p2) (neq p1 (cdr dir))) + (when (and (null p2) (or t (neq p1 (cdr dir)))) (setq dir (cons :relative p1))))))) (setq dir (%directory-list-namestring dir logical-p)) Index: /branches/event-ide/ccl/level-1/l1-init.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-init.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-init.lisp (revision 8262) @@ -122,5 +122,5 @@ -(defconstant internal-time-units-per-second 1000 +(defconstant internal-time-units-per-second #+64-bit-target 1000000 #-64-bit-target 1000 "The number of internal time units that fit into a second. See GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") Index: /branches/event-ide/ccl/level-1/l1-io.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-io.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-io.lisp (revision 8262) @@ -1657,4 +1657,8 @@ (format stream "for ") (%lfun-name-string (%function-vector-to-function fv) stream))) + +(defmethod print-object ((c class-cell) stream) + (print-unreadable-object (c stream :type t :identity t) + (format stream "for ~s" (class-cell-name c)))) Index: /branches/event-ide/ccl/level-1/l1-lisp-threads.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-lisp-threads.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-lisp-threads.lisp (revision 8262) @@ -84,16 +84,18 @@ (rlet ((tv :timeval)) (#_gettimeofday tv (%null-ptr)) - (let* ((micros (truncate (the fixnum (pref tv :timeval.tv_usec)) 1000)) + (let* ((units (truncate (the fixnum (pref tv :timeval.tv_usec)) (/ 1000000 internal-time-units-per-second))) (initial *internal-real-time-session-seconds*)) (if initial (locally (declare (type (unsigned-byte 32) initial)) - (+ (* 1000 (the (unsigned-byte 32) - (- (the (unsigned-byte 32) (pref tv :timeval.tv_sec)) - initial))) micros)) + (+ (* internal-time-units-per-second + (the (unsigned-byte 32) + (- (the (unsigned-byte 32) (pref tv :timeval.tv_sec)) + initial))) + units)) (progn (setq *internal-real-time-session-seconds* (pref tv :timeval.tv_sec)) - micros))))) + units))))) (defun get-tick-count () @@ -305,28 +307,5 @@ -(defmacro with-self-bound-io-control-vars (&body body) - `(let (; from CLtL2, table 22-7: - (*package* *package*) - (*print-array* *print-array*) - (*print-base* *print-base*) - (*print-case* *print-case*) - (*print-circle* *print-circle*) - (*print-escape* *print-escape*) - (*print-gensym* *print-gensym*) - (*print-length* *print-length*) - (*print-level* *print-level*) - (*print-lines* *print-lines*) - (*print-miser-width* *print-miser-width*) - (*print-pprint-dispatch* *print-pprint-dispatch*) - (*print-pretty* *print-pretty*) - (*print-radix* *print-radix*) - (*print-readably* *print-readably*) - (*print-right-margin* *print-right-margin*) - (*read-base* *read-base*) - (*read-default-float-format* *read-default-float-format*) - (*read-eval* *read-eval*) - (*read-suppress* *read-suppress*) - (*readtable* *readtable*)) - ,@body)) + @@ -966,8 +945,8 @@ -(defvar *termination-population* +(defstatic *termination-population* (%cons-terminatable-alist)) -(defvar *termination-population-lock* (make-lock)) +(defstatic *termination-population-lock* (make-lock)) @@ -982,10 +961,9 @@ or releasing of resources which needs to happen when a certain object is no longer being used." - (let ((new-cell (list (cons object function))) + (let ((new-cell (cons object function)) (population *termination-population*)) (without-interrupts (with-lock-grabbed (*termination-population-lock*) - (setf (cdr new-cell) (population-data population) - (population-data population) new-cell))) + (atomic-push-uvector-cell population population.data new-cell))) function)) @@ -994,31 +972,40 @@ (defun drain-termination-queue () - (let ((cell nil) - (population *termination-population*)) - (loop - (without-interrupts - (with-lock-grabbed (*termination-population-lock*) - (without-gcing - (let ((list (population-termination-list population))) - (unless list (return)) - (setf cell (car list) - (population-termination-list population) (cdr list)))))) - (funcall (cdr cell) (car cell))))) + (with-lock-grabbed (*termination-population-lock*) + (let* ((population *termination-population*)) + (loop + (multiple-value-bind (cell existed) + (atomic-pop-uvector-cell population population.termination-list) + (if (not existed) + (return) + (funcall (cdr cell) (car cell)))))))) (defun cancel-terminate-when-unreachable (object &optional (function nil function-p)) - (let ((found-it? nil)) - (flet ((test (object cell) - (and (eq object (car cell)) - (or (not function-p) - (eq function (cdr cell))) - (setq found-it? t)))) - (declare (dynamic-extent #'test)) - (without-interrupts - (with-lock-grabbed (*termination-population-lock*) - (setf (population-data *termination-population*) - (delete object (population-data *termination-population*) - :test #'test - :count 1)))) - found-it?))) + (let* ((found nil)) + (with-lock-grabbed (*termination-population-lock*) + ;; Have to defer GCing, e.g., defer responding to a GC + ;; suspend request here (that also defers interrupts) + ;; We absolutely, positively can't take an exception + ;; in here, so don't even bother to typecheck on + ;; car/cdr etc. + (with-deferred-gc + (do ((spine (population-data *termination-population*) (cdr spine)) + (prev nil spine)) + ((null spine)) + (declare (optimize (speed 3) (safety 0))) + (let* ((head (car spine)) + (tail (cdr spine)) + (o (car head)) + (f (cdr head))) + (when (and (eq o object) + (or (null function-p) + (eq function f))) + (if prev + (setf (cdr prev) tail) + (setf (population-data *termination-population*) tail)) + (setq found t) + (return))))) + found))) + (defun termination-function (object) @@ -1115,6 +1102,6 @@ (setq *current-lisp-thread* thread *current-process* - (make-process "foreign" :thread thread)) - (setf (%process-whostate *current-process*) "Foreign thread callback"))) + (make-process "foreign" :thread thread) + *whostate* "Foreign thread callback"))) ;;; Remove the foreign thread's lisp-thread and lisp process from Index: /branches/event-ide/ccl/level-1/l1-numbers.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-numbers.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-numbers.lisp (revision 8262) @@ -421,4 +421,16 @@ nil))) +(defun %cons-random-state (seed-1 seed-2) + #+32-bit-target + (gvector :istruct + 'random-state + seed-1 + seed-2) + #+64-bit-target + (gvector :istruct + 'random-state + (the fixnum (+ (the fixnum seed-2) + (the fixnum (ash (the fixnum seed-1) 16)))))) + ;;; random associated stuff except for the print-object method which ;;; is still in "lib;numbers.lisp" @@ -428,12 +440,5 @@ (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000)) (report-bad-arg seed-2 '(unsigned-byte 16))) - (gvector :istruct - 'random-state - seed-1 - seed-2)) - - - - + (%cons-random-state seed-1 seed-2)) (defun make-random-state (&optional state) @@ -449,5 +454,5 @@ (setq state (require-type (or state *random-state*) 'random-state)) (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state)))) - (gvector :istruct 'random-state seed-1 seed-2))) + (%cons-random-state seed-1 seed-2))) (defun random-state-p (thing) (istruct-typep thing 'random-state)) Index: /branches/event-ide/ccl/level-1/l1-processes.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-processes.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-processes.lisp (revision 8262) @@ -119,5 +119,4 @@ (priority :initform 0 :initarg :priority :accessor process-priority) (persistent :initform nil :initarg :persistent :reader process-persistent) - (whostate :initform "Reset" :accessor %process-whostate) (splice :initform (cons nil nil) :accessor process-splice) (initial-bindings :initform nil :initarg :initial-bindings @@ -192,5 +191,4 @@ :thread *initial-lisp-thread* :priority 0))) - (setf (%process-whostate p) "Active") p)) @@ -219,7 +217,9 @@ (if (process-exhausted-p p) "Exhausted" - (%process-whostate p))) - - + (symbol-value-in-process '*whostate* p))) + +(defun (setf process-whostate) (new p) + (unless (process-exhausted-p p) + (setf (symbol-value-in-process '*whostate* p) new))) @@ -242,8 +242,12 @@ (defun symbol-value-in-process (sym process) - (symbol-value-in-tcr sym (process-tcr process))) + (if (eq process *current-process*) + (symbol-value sym) + (symbol-value-in-tcr sym (process-tcr process)))) (defun (setf symbol-value-in-process) (value sym process) - (setf (symbol-value-in-tcr sym (process-tcr process)) value)) + (if (eq process *current-process*) + (setf (symbol-value sym) value) + (setf (symbol-value-in-tcr sym (process-tcr process)) value))) @@ -257,5 +261,4 @@ (do* ((total-wait wait (+ total-wait wait))) ((thread-enable thread (process-termination-semaphore p) (1- (integer-length (process-allocation-quantum p))) wait) - (setf (%process-whostate p) "Active") p) (cerror "Keep trying." @@ -325,4 +328,5 @@ (initial-bindings (process-initial-bindings process)) (progv syms values + (setq *whostate* "Active") (run-process-initial-form process initial-form))))) process @@ -356,6 +360,5 @@ (progn (thread-change-state (process-thread process) :run :reset) - (tcr-set-preset-state (process-tcr process)) - (setf (%process-whostate process) "Reset"))) + (tcr-set-preset-state (process-tcr process)))) nil)) @@ -366,5 +369,5 @@ (if (eq kill :shutdown) (progn - (setf (%process-whostate process) "Shutdown") + (setq *whostate* "Shutdown") (add-to-shutdown-processes process))) (maybe-finish-process-kill process kill))) @@ -372,5 +375,5 @@ (defun maybe-finish-process-kill (process kill) (when (and kill (neq kill :shutdown)) - (setf (%process-whostate process) "Dead") + (setf (process-whostate process) "Dead") (remove-from-all-processes process) (let ((thread (process-thread process))) @@ -423,13 +426,13 @@ (defun grab-lock (lock &optional flag) "Wait until a given lock can be obtained, then obtain it." - (%lock-recursive-lock (recursive-lock-ptr lock) flag)) + (%lock-recursive-lock-object lock flag)) (defun release-lock (lock) "Relinquish ownership of a given lock." - (%unlock-recursive-lock (recursive-lock-ptr lock))) + (%unlock-recursive-lock-object lock)) (defun try-lock (lock &optional flag) "Obtain the given lock, but only if it is not necessary to wait for it." - (%try-recursive-lock (recursive-lock-ptr lock) flag)) + (%try-recursive-lock-object lock flag)) (defun lock-acquisition-status (thing) @@ -676,2 +679,11 @@ (defaultp default) (t (error "Failed to join ~s" p))))) + + +(defmethod process-locks-held ((p process)) + #+lock-accounting + (copy-list (symbol-value-in-process '*locks-held* p))) + +(defmethod process-locks-pending ((p process)) + #+lock-accounting + (copy-list (symbol-value-in-process '*locks-pending* p))) Index: /branches/event-ide/ccl/level-1/l1-reader.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-reader.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-reader.lisp (revision 8262) @@ -2481,5 +2481,5 @@ ((functionp (car def)) (funcall (car def) stream firstchar)) - (t (break "Bogus default dispatch fn: ~S" (car def)) nil))))))) + (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))) (declare (dynamic-extent vals) (list vals)) Index: /branches/event-ide/ccl/level-1/l1-readloop-lds.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-readloop-lds.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-readloop-lds.lisp (revision 8262) @@ -142,4 +142,16 @@ :detailed-p t)) +(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame" + (let* ((frame-sp (nth-raw-frame i *break-frame* nil))) + (if frame-sp + (apply #'return-from-frame frame-sp values)))) + +(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame" + (let* ((frame-sp (nth-raw-frame i *break-frame* nil))) + (if frame-sp + (apply-in-frame frame-sp function args)))) + + + (define-toplevel-command :break raw (n) "Show raw contents of backtrace frame " (print-call-history :origin *break-frame* @@ -152,4 +164,47 @@ (if frame-sp (toplevel-print (list (nth-value-in-frame frame-sp n nil)))))) + +(define-toplevel-command :break arg (name frame-number) "Return value of argument named in frame " + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (let* ((unavailable (cons nil nil))) + (declare (dynamic-extent unavailable)) + (let* ((value (arg-value nil frame-sp lfun pc unavailable name))) + (if (eq value unavailable) + (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) + (toplevel-print (list value)))))))))) + +(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named in frame to value ." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (or (set-arg-value nil frame-sp lfun pc name new) + (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) + + +(define-toplevel-command :break local (name frame-number) "Return value of local denoted by in frame can either be a symbol - in which case the most recent +binding of that symbol is used - or an integer index into the frame's set of local bindings." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (let* ((unavailable (cons nil nil))) + (declare (dynamic-extent unavailable)) + (let* ((value (local-value nil frame-sp lfun pc unavailable name))) + (if (eq value unavailable) + (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) + (toplevel-print (list value)))))))))) + +(define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted (see :LOCAL) in frame to value ." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (or (set-local-value nil frame-sp lfun pc name new) + (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) + (define-toplevel-command :break form (frame-number) @@ -358,30 +413,39 @@ (break-loop-handle-error condition error-pointer)) +(defun abnormal-application-exit () + (print-call-history) + (force-output *debug-io*) + (quit -1)) + (defun break-loop-handle-error (condition error-pointer) (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals) (dolist (x bogus-globals) (set x (funcall (pop newvals)))) - (when (and *debugger-hook* *break-on-errors*) + (when (and *debugger-hook* *break-on-errors* (not *batch-flag*)) (let ((hook *debugger-hook*) (*debugger-hook* nil)) (funcall hook condition hook))) (%break-message "Error" condition error-pointer) - (with-terminal-input - (let* ((s *error-output*)) - (dolist (bogusness bogus-globals) - (let ((oldval (pop oldvals))) - (format s "~&; NOTE: ~S was " bogusness) - (if (eq oldval (%unbound-marker-8)) - (format s "unbound") - (format s "~s" oldval)) - (format s ", was reset to ~s ." (symbol-value bogusness))))) - (if *break-on-errors* - (break-loop condition error-pointer) - (abort))))) + (let* ((s *error-output*)) + (dolist (bogusness bogus-globals) + (let ((oldval (pop oldvals))) + (format s "~&; NOTE: ~S was " bogusness) + (if (eq oldval (%unbound-marker-8)) + (format s "unbound") + (format s "~s" oldval)) + (format s ", was reset to ~s ." (symbol-value bogusness))))) + (if (and *break-on-errors* (not *batch-flag*)) + (with-terminal-input + (break-loop condition error-pointer)) + (if *batch-flag* + (abnormal-application-exit) + (abort))))) (defun break (&optional string &rest args) "Print a message and invoke the debugger without allowing any possibility of condition handling occurring." - (apply #'%break-in-frame (%get-frame-ptr) string args)) + (if *batch-flag* + (apply #'error string args) + (apply #'%break-in-frame (%get-frame-ptr) string args))) (defun %break-in-frame (fp &optional string &rest args) @@ -423,6 +487,6 @@ (*print-escape* t) (*print-gensym* t) - (*print-length* *backtrace-print-length*) ; ? - (*print-level* *backtrace-print-level*) ; ? + (*print-length* *error-print-length*) + (*print-level* *error-print-level*) (*print-lines* nil) (*print-miser-width* nil) @@ -537,6 +601,6 @@ (if *continuablep* (let* ((*print-circle* *error-print-circle*) - (*print-level* *backtrace-print-level*) - (*print-length* *backtrace-print-length*) + (*print-level* *error-print-level*) + (*print-length* *error-print-length*) ;(*print-pretty* nil) (*print-array* nil)) Index: /branches/event-ide/ccl/level-1/l1-sockets.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-sockets.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-sockets.lisp (revision 8262) @@ -148,5 +148,5 @@ "WITH-OPEN-SOCKET")) -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :execute) #+linuxppc-target (require "PPC-LINUX-SYSCALLS") @@ -168,5 +168,5 @@ (define-condition socket-creation-error (simple-error) ((code :initarg :code :reader socket-creation-error-code) - (identifier :initform :unknown :initarg :identifier :reader socket-creationg-error-identifier) + (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier) (situation :initarg :situation :reader socket-creation-error-situation))) @@ -219,10 +219,10 @@ ;; TODO: this is a constant arg, there is a way to put this ;; in the class definition, just need to remember how... - :format-control "~a (error #~d) on ~s in ~a" + :format-control "~a (error #~d) during ~a" :format-arguments (list (if nameserver-p (%hstrerror errno) (%strerror errno)) - errno stream where))) + errno where))) (error (make-condition 'socket-creation-error :code errno @@ -231,16 +231,17 @@ ;; TODO: this is a constant arg, there is a way to put this ;; in the class definition, just need to remember how... - :format-control "~a (error #~d) on ~s in ~a" + :format-control "~a (error #~d) during socket creation in ~a" :format-arguments (list (if nameserver-p (%hstrerror errno) (%strerror errno)) - errno stream where))))) + errno where))))) -;; If true, this will try to allow other processes to run while -;; socket io is happening. -(defvar *multiprocessing-socket-io* t) +;; If true, this will try to allow other cooperative processes to run +;; while socket io is happening. Since CCL threads are preemptively +;; scheduled, this isn't particularly meaningful. +(defvar *multiprocessing-socket-io* nil) (defclass socket () @@ -532,4 +533,6 @@ connect out-of-band-inline + receive-timeout + send-timeout &allow-other-keys) ;; see man socket(7) tcp(7) ip(7) @@ -559,4 +562,14 @@ #+(or freebsd-target darwin-target) #$IPPROTO_TCP #$TCP_NODELAY 1)) + (when (and receive-timeout (> receive-timeout 0)) + (timeval-setsockopt fd + #$SOL_SOCKET + #$SO_RCVTIMEO + receive-timeout)) + (when (and send-timeout (> send-timeout 0)) + (timeval-setsockopt fd + #$SOL_SOCKET + #$SO_SNDTIMEO + send-timeout)) (when (or local-port local-host) (let* ((proto (if (eq type :stream) "tcp" "udp")) @@ -577,5 +590,5 @@ local-filename) (bind-unix-socket fd local-filename)) - (when *multiprocessing-socket-io* + (when (and nil *multiprocessing-socket-io*) (socket-call socket "fcntl" (fd-set-flag fd #$O_NONBLOCK))))) @@ -603,5 +616,6 @@ local-port local-host backlog class out-of-band-inline local-filename remote-filename sharing basic - external-format) + external-format (auto-close t) + receive-timeout send-timeout) "Create and return a new socket." (declare (dynamic-extent keys)) @@ -609,5 +623,6 @@ keepalive reuse-address nodelay broadcast linger local-port local-host backlog class out-of-band-inline - local-filename remote-filename sharing basic external-format)) + local-filename remote-filename sharing basic external-format + auto-close receive-timeout send-timeout)) (ecase address-family ((:file) (apply #'make-file-socket keys)) @@ -696,5 +711,5 @@ -(defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) &allow-other-keys) +(defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) (receive-timeout 0) &allow-other-keys) (let* ((external-format (normalize-external-format :socket external-format))) (let ((element-type (ecase format @@ -711,7 +726,9 @@ :encoding (external-format-character-encoding external-format) :line-termination (external-format-line-termination external-format) - :basic basic)))) - -(defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream) sharing basic &allow-other-keys) + :basic basic + :auto-close auto-close + :interactive (zerop receive-timeout))))) + +(defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream) sharing basic (auto-close t) &allow-other-keys) (let* ((external-format (normalize-external-format :socket external-format))) @@ -729,5 +746,6 @@ :sharing sharing :character-p (not (eq format :binary)) - :basic basic)))) + :basic basic + :auto-close auto-close)))) (defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys) @@ -973,4 +991,11 @@ (socket-error socket "getsockopt" err))))) +(defun timeval-setsockopt (socket level optname timeout) + (multiple-value-bind (seconds millis) + (milliseconds timeout) + (rlet ((valptr :timeval :tv_sec seconds :tv_usec millis)) + (socket-call socket "setsockopt" + (c_setsockopt socket level optname valptr (record-length :timeval)))))) + (defun int-setsockopt (socket level optname optval) (rlet ((valptr :signed)) @@ -1104,5 +1129,5 @@ (pref addr :in_addr.s_addr)))))) -(defun c_socket (domain type protocol) +(defun c_socket_1 (domain type protocol) #-linuxppc-target (syscall syscalls::socket domain type protocol) @@ -1113,4 +1138,14 @@ (paref params (:* :unsigned-long) 2) protocol) (syscall syscalls::socketcall 1 params))) + +(defun c_socket (domain type protocol) + (let* ((fd (c_socket_1 domain type protocol))) + (when (or (eql fd (- #$EMFILE)) + (eql fd (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq fd (c_socket_1 domain type protocol))) + fd)) + (defun init-unix-sockaddr (addr path) @@ -1476,4 +1511,5 @@ (or (find-if #'(lambda (i) (and (eq #$AF_INET (ip-interface-address-family i)) + (ip-interface-addr i) (let* ((flags (ip-interface-flags i))) (and (not (logtest #$IFF_LOOPBACK flags)) Index: /branches/event-ide/ccl/level-1/l1-streams.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-streams.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-streams.lisp (revision 8262) @@ -62,6 +62,7 @@ ;;; stream's current position, if that makes sense. Return NIL ;;; if it doesn't make sense. -;;; Catch cases where this is used when STREAM-ERRORs (SOCKET-ERRORs) -;;; are signaled on non-STREAMs. +;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs +;;; whose STREAM args aren't streams. That's wrong, but +;;; defining this method on T keeps things from blowing up worse. (defmethod stream-surrounding-characters ((s t)) (declare (ignore s)) @@ -3257,5 +3258,7 @@ - +(defun optimal-buffer-size (fd) + (or (nth-value 6 (%fstat fd)) *elements-per-buffer*)) + ;;; Note that we can get "bivalent" streams by specifiying :character-p t @@ -3264,5 +3267,5 @@ (direction :input) (interactive t) - (elements-per-buffer *elements-per-buffer*) + (elements-per-buffer (optimal-buffer-size fd)) (element-type 'character) (class 'fd-stream) @@ -3272,5 +3275,6 @@ (basic nil) encoding - line-termination) + line-termination + auto-close) (when line-termination (setq line-termination @@ -3282,22 +3286,29 @@ (out-p (member direction '(:io :output))) (class-name (select-stream-class class in-p out-p character-p)) - (class (find-class class-name))) - (make-ioblock-stream class - :insize (if in-p elements-per-buffer) - :outsize (if out-p elements-per-buffer) - :device fd - :interactive interactive - :element-type element-type - :advance-function (if in-p - (select-stream-advance-function class direction)) - :listen-function (if in-p 'fd-stream-listen) - :eofp-function (if in-p 'fd-stream-eofp) - :force-output-function (if out-p - (select-stream-force-output-function class direction)) - :close-function 'fd-stream-close - :sharing sharing - :character-p character-p - :encoding encoding - :line-termination line-termination))) + (class (find-class class-name)) + (stream + (make-ioblock-stream class + :insize (if in-p elements-per-buffer) + :outsize (if out-p elements-per-buffer) + :device fd + :interactive interactive + :element-type element-type + :advance-function (if in-p + (select-stream-advance-function class direction)) + :listen-function (if in-p 'fd-stream-listen) + :eofp-function (if in-p 'fd-stream-eofp) + :force-output-function (if out-p + (select-stream-force-output-function class direction)) + :close-function 'fd-stream-close + :sharing sharing + :character-p character-p + :encoding encoding + :line-termination line-termination))) + (if auto-close + (terminate-when-unreachable stream + (lambda (stream) + (close stream :abort t)))) + stream)) + ;;; Fundamental streams. @@ -3337,5 +3348,5 @@ (defmethod stream-external-format ((s character-stream)) - (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix)) + (make-external-format :character-encoding #+big-endian-target :utf32-be #+little-endian-target :utf32-le :line-termination :unix)) @@ -3593,6 +3604,5 @@ s)) -(defmethod %stream-ioblock ((s basic-stream)) - (basic-stream.state s)) + (defmethod (setf stream-ioblock) (ioblock (s basic-stream)) @@ -4079,5 +4089,5 @@ (broadcast-method stream-force-output (s)) (broadcast-method stream-finish-output (s)) - (broadcast-method stream-stream-write-list (s l c)) + (broadcast-method stream-write-list (s l c)) (broadcast-method stream-write-vector (s v start end))) @@ -4639,5 +4649,7 @@ (defun stream-ioblock (stream error-if-nil) - (or (%stream-ioblock stream) + (or (if (typep stream 'basic-stream) + (basic-stream.state stream) + (%stream-ioblock stream)) (when error-if-nil (stream-is-closed stream)))) @@ -4749,5 +4761,5 @@ (defmethod stream-surrounding-characters ((stream basic-character-input-stream)) - (let* ((ioblock (stream-ioblock stream nil))) + (let* ((ioblock (basic-stream.state stream))) (and ioblock (%ioblock-surrounding-characters ioblock)))) @@ -5189,4 +5201,9 @@ :unsigned-fullword))))) +(defun process-input-would-block (fd) + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-input-wait fd) + (- #$ETIMEDOUT))) + (defun process-input-wait (fd &optional ticks) "Wait until input is available on a given file-descriptor." @@ -5209,4 +5226,8 @@ +(defun process-output-would-block (fd) + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-output-wait fd) + (- #$ETIMEDOUT))) (defun process-output-wait (fd) @@ -5336,9 +5357,5 @@ (io-buffer-count buf) 0 (ioblock-eof ioblock) nil) - (let* ((avail nil)) - (when (or read-p (setq avail (stream-listen s))) - (if (and (ioblock-interactive ioblock) - (not avail)) - (process-input-wait fd)) + (when (or read-p (stream-listen s)) (let* ((n (with-eagain fd :input (fd-read fd bufptr size)))) @@ -5350,5 +5367,5 @@ (ioblock-octets-to-elements ioblock n)) (progn (setf (ioblock-eof ioblock) t) - nil)))))))) + nil))))))) (defun fd-stream-eofp (s ioblock) @@ -5361,4 +5378,5 @@ (defun fd-stream-close (s ioblock) + (cancel-terminate-when-unreachable s) (when (ioblock-dirty ioblock) (stream-finish-output s)) @@ -5370,4 +5388,5 @@ (defun fd-stream-force-output (s ioblock count finish-p) (when (or (ioblock-dirty ioblock) finish-p) + (setf (ioblock-dirty ioblock) nil) (let* ((fd (ioblock-device ioblock)) (io-buffer (ioblock-outbuf ioblock)) @@ -5377,23 +5396,21 @@ (declare (fixnum octets)) (declare (dynamic-extent buf)) - (without-interrupts - (setf (ioblock-dirty ioblock) nil) - (%setf-macptr buf (io-buffer-bufptr io-buffer)) - (setf (io-buffer-idx io-buffer) 0 - (io-buffer-count io-buffer) 0) - (do* () - ((= octets 0) - (when finish-p - (case (%unix-fd-kind fd) - (:file (fd-fsync fd)))) - octets-to-write) - (let* ((written (with-eagain fd :output - (fd-write fd buf octets)))) - (declare (fixnum written)) - (if (< written 0) - (stream-io-error s (- written) "write")) - (decf octets written) - (unless (zerop octets) - (%incf-ptr buf written)))))))) + (%setf-macptr buf (io-buffer-bufptr io-buffer)) + (setf (io-buffer-idx io-buffer) 0 + (io-buffer-count io-buffer) 0) + (do* () + ((= octets 0) + (when finish-p + (case (%unix-fd-kind fd) + (:file (fd-fsync fd)))) + octets-to-write) + (let* ((written (with-eagain fd :output + (fd-write fd buf octets)))) + (declare (fixnum written)) + (if (< written 0) + (stream-io-error s (- written) "write")) + (decf octets written) + (unless (zerop octets) + (%incf-ptr buf written))))))) (defmethod stream-read-line ((s buffered-input-stream-mixin)) @@ -5428,8 +5445,7 @@ (defclass selection-input-stream (fd-character-input-stream) - ((package :initform nil :reader selection-input-stream-package) - (pathname :initform nil :reader selection-input-stream-pathname) - (env :initform nil :reader selection-input-stream-env) - (peer-fd :reader selection-input-stream-peer-fd))) + ((package :initform nil :reader selection-input-stream-package) + (pathname :initform nil :reader selection-input-stream-pathname) + (peer-fd :reader selection-input-stream-peer-fd))) (defmethod select-stream-class ((class (eql 'selection-input-stream)) @@ -5455,5 +5471,5 @@ ;;; else raw data (defmethod stream-read-char ((s selection-input-stream)) - (with-slots (env package pathname) s + (with-slots (package pathname) s (let* ((quoted nil)) (loop @@ -5462,9 +5478,9 @@ (return ch) (case ch - (#\^p (setq package nil env nil) + (#\^p (setq package nil) (let* ((p (read-line s nil nil))) (unless (zerop (length p)) (setq package p)))) - (#\^v (setq pathname nil env nil) + (#\^v (setq pathname nil) (let* ((p (read-line s nil nil))) (unless (zerop (length p)) @@ -5561,5 +5577,5 @@ (tem-path (merge-pathnames (make-pathname :name (%integer-to-string date) :type "tem" :defaults nil) path))) (loop - (when (not (probe-file tem-path)) (return tem-path)) + (when (%create-file tem-path :if-exists nil) (return tem-path)) (setf (%pathname-name tem-path) (%integer-to-string (setq date (1+ date))))))) @@ -5640,5 +5656,5 @@ ;;; Interaction with the REPL. READ-TOPLEVEL-FORM should return 3 -;;; values: a form, a (possibly null) evaluation env, and a boolean that +;;; values: a form, a (possibly null) pathname, and a boolean that ;;; indicates whether or not the result(s) of evaluating the form ;;; should be printed. (The last value has to do with how selections @@ -5690,17 +5706,15 @@ eof-value) (if (eq (stream-peek-char stream) :eof) - (with-slots (env package pathname) stream - (setf env nil package nil pathname nil) - (values eof-value nil t)) - (with-slots (env package pathname) stream - (when (and (or package pathname) (null env)) - (setf env (cons '(*package* *loading-file-source-file*) - (list (or (and package (pkg-arg package)) *package*) pathname)))) - (let* ((form (progv (car env) (cdr env) - (call-next-method))) + (values eof-value nil t) + (let* ((*package* *package*) + (pkg-name (selection-input-stream-package stream))) + (when pkg-name (setq *package* (pkg-arg pkg-name))) + (let* ((form (call-next-method)) (last-form-in-selection (not (listen stream)))) - (values form env (or last-form-in-selection *verbose-eval-selection*)))))) - - + (values form + (selection-input-stream-pathname stream) + (or last-form-in-selection *verbose-eval-selection*)))))) + + (defun column (&optional stream) (let* ((stream (real-print-stream stream))) @@ -5722,8 +5736,8 @@ (defmethod stream-external-format ((s basic-character-stream)) - (%ioblock-external-format (stream-ioblock s t))) + (%ioblock-external-format (basic-stream-ioblock s))) (defmethod (setf stream-external-format) (new (s basic-character-stream)) - (setf (%ioblock-external-format (stream-ioblock s t)) + (setf (%ioblock-external-format (basic-stream-ioblock s)) (normalize-external-format (stream-domain s) new))) Index: /branches/event-ide/ccl/level-1/l1-sysio.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-sysio.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-sysio.lisp (revision 8262) @@ -514,5 +514,5 @@ (file-octet-filepos file-ioblock)))) (unless (eql newpos curpos) - (break "Expected newpos to be ~d, fd is at ~d" newpos curpos)) + (error "Expected newpos to be ~d, fd is at ~d" newpos curpos)) (setf (file-ioblock-octet-pos file-ioblock) newpos) (fd-stream-advance stream file-ioblock read-p))) @@ -529,5 +529,5 @@ (fd-stream-force-output stream file-ioblock count nil)) (unless (eql newpos (file-octet-filepos file-ioblock)) - (break "Expected newpos to be ~d, fd is at ~d" + (error "Expected newpos to be ~d, fd is at ~d" newpos (file-octet-filepos file-ioblock))) (setf (file-ioblock-octet-pos file-ioblock) newpos) @@ -539,5 +539,5 @@ (let* ((curpos (file-ioblock-octet-pos file-ioblock))) (unless (eql curpos (file-octet-filepos file-ioblock)) - (break "Expected newpos to be ~d, fd is at ~d" + (error "Expected newpos to be ~d, fd is at ~d" curpos (file-octet-filepos file-ioblock))) (let* ((n (fd-stream-force-output stream file-ioblock count finish-p))) @@ -773,5 +773,6 @@ (return-from open nil))) (if (setq filename (if-does-not-exist if-does-not-exist filename)) - (setq native-truename (%create-file filename)) + (unless (setq native-truename (%create-file filename :if-exists if-exists)) + (return-from open nil)) (return-from open nil))) (let* ((fd (fd-open native-truename (case direction Index: /branches/event-ide/ccl/level-1/l1-typesys.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-typesys.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-typesys.lisp (revision 8262) @@ -1529,4 +1529,9 @@ (defvar *empty-type* (define-named-ctype nil)) (defvar *universal-type* (define-named-ctype t)) + +(defun named-ctype-p (x) + (istruct-typep x 'named-ctype)) + +(setf (type-predicate 'named-ctype) 'named-ctype-p) (define-type-method (named :simple-=) (type1 type2) @@ -2625,5 +2630,7 @@ complexp element-type - specialized-element-type)) + specialized-element-type + (unless (eq specialized-element-type *wild-type*) + (ctype-subtype specialized-element-type)))) (defun array-ctype-p (x) (istruct-typep x 'array-ctype)) @@ -2671,20 +2678,20 @@ (case eltype (bit 'bit-vector) - (base-char 'base-string) + ((character base-char) 'base-string) (* 'vector) (t `(vector ,eltype))) (case eltype (bit `(bit-vector ,(car dims))) - (base-char `(base-string ,(car dims))) + ((character base-char) `(base-string ,(car dims))) (t `(vector ,eltype ,(car dims))))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) - (base-char 'simple-base-string) + ((base-char character) 'simple-base-string) ((t) 'simple-vector) (t `(simple-array ,eltype (*)))) (case eltype (bit `(simple-bit-vector ,(car dims))) - (base-char `(simple-base-string ,(car dims))) + ((base-char character) `(simple-base-string ,(car dims))) ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) @@ -2830,15 +2837,16 @@ (defun specialize-array-type (type) - (let ((eltype (array-ctype-element-type type))) + (let* ((eltype (array-ctype-element-type type)) + (specialized-type (if (eq eltype *wild-type*) + *wild-type* + (dolist (stype-name specialized-array-element-types + *universal-type*) + (let ((stype (specifier-type stype-name))) + (when (csubtypep eltype stype) + (return stype))))))) - (setf (array-ctype-specialized-element-type type) - (if (eq eltype *wild-type*) - *wild-type* - (dolist (stype-name specialized-array-element-types - *universal-type*) - (let ((stype (specifier-type stype-name))) - (when (csubtypep eltype stype) - (return stype)))))) - + (setf (array-ctype-specialized-element-type type) specialized-type + (array-ctype-typecode type) (unless (eq specialized-type *wild-type*) + (ctype-subtype specialized-type))) type)) @@ -3381,4 +3389,16 @@ (setf (type-predicate 'class-ctype) 'class-ctype-p) +(defun args-ctype-p (x) (and (eql (typecode x) target::subtag-istruct) + (member (%svref x 0) + '(args-ctype values-ctype function-ctype)))) + +(defun function-ctype-p (x) (istruct-typep x 'function-ctype)) +(defun valuec-ctype-p (x) (istruct-typep x 'values-ctype)) + +(setf (type-predicate 'args-ctype) 'args-ctype-p + (type-predicate 'function-ctype) 'function-ctype-p + (type-predicate 'values-ctype) 'values-ctype-p) + + ;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two ;;; classes are equal, since there are EQ checks in those operations. @@ -3575,4 +3595,85 @@ (specifier-type specifier)))) +(eval-when (:compile-toplevel) + (declaim (inline numeric-%%typep + array-%%typep + member-%%typep + cons-%%typep))) + +(defun numeric-%%typep (object type) + (let ((pred (numeric-ctype-predicate type))) + (if pred + (funcall pred object) + (and (numberp object) + (let ((num (if (complexp object) (realpart object) object))) + (ecase (numeric-ctype-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-ctype-format type) + (single-float (typep num 'single-float)) + (double-float (typep num 'double-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-ctype-low type)) + (high (numeric-ctype-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-ctype-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (bound-test (realpart object)) + (bound-test (imagpart object)))) + (:real + (and (not (complexp object)) + (bound-test object))))))))) + +(defun array-%%typep (object type) + (let* ((typecode (typecode object))) + (declare (type (unsigned-byte 8) typecode)) + (and (>= typecode target::subtag-arrayH) + (ecase (array-ctype-complexp type) + ((t) (not (simple-array-p object))) + ((nil) (simple-array-p object)) + ((* :maybe) t)) + (let* ((ctype-dimensions (array-ctype-dimensions type)) + (header-p (= typecode target::subtag-arrayH))) + (or (eq (array-ctype-dimensions type) '*) + (and (null (cdr ctype-dimensions)) (not header-p)) + (and header-p + (let* ((rank (%svref object target::arrayH.rank-cell))) + (declare (fixnum rank)) + (and (= rank (length ctype-dimensions)) + (do* ((i 0 (1+ i)) + (dim target::arrayH.dim0-cell (1+ dim)) + (want (array-ctype-dimensions type) (cdr want)) + (got (%svref object dim) (%svref object dim))) + ((= i rank) t) + (unless (or (eq (car want) '*) + (= (car want) got)) + (return nil))))))) + (or (eq (array-ctype-element-type type) *wild-type*) + (eql (array-ctype-typecode type) + (if (> typecode target::subtag-vectorH) + typecode + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell))))) + (type= (array-ctype-specialized-element-type type) + (specifier-type (array-element-type object)))))))) + + +(defun member-%%typep (object type) + (not (null (member object (member-ctype-members type))))) + +(defun cons-%%typep (object type) + (and (consp object) + (%%typep (car object) (cons-ctype-car-ctype type)) + (%%typep (cdr object) (cons-ctype-cdr-ctype type)))) + (defun %%typep (object type) @@ -3585,55 +3686,9 @@ ((nil) nil))) (numeric-ctype - (let ((pred (numeric-ctype-predicate type))) - (if Pred - (funcall pred object) - (and (numberp object) - (let ((num (if (complexp object) (realpart object) object))) - (ecase (numeric-ctype-class type) - (integer (integerp num)) - (rational (rationalp num)) - (float - (ecase (numeric-ctype-format type) - (single-float (typep num 'single-float)) - (double-float (typep num 'double-float)) - ((nil) (floatp num)))) - ((nil) t))) - (flet ((bound-test (val) - (let ((low (numeric-ctype-low type)) - (high (numeric-ctype-high type))) - (and (cond ((null low) t) - ((listp low) (> val (car low))) - (t (>= val low))) - (cond ((null high) t) - ((listp high) (< val (car high))) - (t (<= val high))))))) - (ecase (numeric-ctype-complexp type) - ((nil) t) - (:complex - (and (complexp object) - (bound-test (realpart object)) - (bound-test (imagpart object)))) - (:real - (and (not (complexp object)) - (bound-test object))))))))) + (numeric-%%typep object type)) (array-ctype - (and (arrayp object) - (ecase (array-ctype-complexp type) - ((t) (not (typep object 'simple-array))) - ((nil) (typep object 'simple-array)) - ((* :maybe) t)) - (or (eq (array-ctype-dimensions type) '*) - (do ((want (array-ctype-dimensions type) (cdr want)) - (got (array-dimensions object) (cdr got))) - ((and (null want) (null got)) t) - (unless (and want got - (or (eq (car want) '*) - (= (car want) (car got)))) - (return nil)))) - (or (eq (array-ctype-element-type type) *wild-type*) - (type= (array-ctype-specialized-element-type type) - (specifier-type (array-element-type object)))))) + (array-%%typep object type)) (member-ctype - (if (member object (member-ctype-members type)) t)) + (member-%%typep object type)) (class-ctype (not (null (class-typep object (class-ctype-class type))))) @@ -3643,10 +3698,8 @@ (return t)))) (intersection-ctype - (every (lambda (type) (%%typep object type)) - (intersection-ctype-types type))) + (dolist (type (intersection-ctype-types type) t) + (unless (%%typep object type) (return nil)))) (cons-ctype - (and (consp object) - (%%typep (car object) (cons-ctype-car-ctype type)) - (%%typep (cdr object) (cons-ctype-cdr-ctype type)))) + (cons-%%typep object type)) (unknown-ctype ;; Parse it again to make sure it's really undefined. @@ -4119,4 +4172,54 @@ +(defvar *simple-predicate-function-prototype* + #'(lambda (thing) + (%%typep thing #.(specifier-type t)))) + +(defun make-simple-type-predicate (function datum) + #+ppc-target + (gvector :function + (uvref *simple-predicate-function-prototype* 0) + datum + function + nil + (dpb 1 $lfbits-numreq 0)) + #+x86-target + (%clone-x86-function + *simple-predicate-function-prototype* + datum + function + nil + (dpb 1 $lfbits-numreq 0))) + +(defun check-ctypep (thing ctype) + (multiple-value-bind (win sure) (ctypep thing ctype) + (or win (not sure)))) + + +(defun generate-predicate-for-ctype (ctype) + (typecase ctype + (numeric-ctype + (or (numeric-ctype-predicate ctype) + (make-simple-type-predicate 'numeric-%%typep ctype))) + (array-ctype + (make-simple-type-predicate 'array-%%typep ctype)) + (member-ctype + (make-simple-type-predicate 'member-%%typep ctype)) + (named-ctype + (case (named-ctype-name ctype) + ((* t) #'true) + (t #'false))) + (cons-ctype + (make-simple-type-predicate 'cons-%%typep ctype)) + (function-ctype + #'functionp) + (class-ctype + (make-simple-type-predicate 'class-cell-typep (find-class-cell (class-name (class-ctype-class ctype)) t))) + (t + (make-simple-type-predicate 'check-ctypep ctype)))) + + + + ;;; Ensure that standard EFFECTIVE-SLOT-DEFINITIONs have a meaningful @@ -4130,20 +4233,20 @@ (setf (slot-value spec 'type-predicate) (or (and (typep type 'symbol) + (not (eq type 't)) (type-predicate type)) (handler-case (let* ((ctype (specifier-type type))) - #'(lambda (value) - (multiple-value-bind (win sure) (ctypep value ctype) - (or (not sure) win)))) + (unless (eq ctype *universal-type*) + (generate-predicate-for-ctype ctype))) (parse-unknown-type (c) - (declare (ignore c)) - #'(lambda (value) - ;; If the type's now known, install a new predicate. - (let* ((nowctype (specifier-type type))) - (unless (typep nowctype 'unknown-ctype) - (setf (slot-value spec 'type-predicate) - #'(lambda (value) (%%typep value nowctype)))) - (multiple-value-bind (win sure) - (ctypep value nowctype) - (or (not sure) win)))))))))) - + (declare (ignore c)) + #'(lambda (value) + ;; If the type's now known, install a new predicate. + (let* ((nowctype (specifier-type type))) + (unless (typep nowctype 'unknown-ctype) + (setf (slot-value spec 'type-predicate) + (generate-predicate-for-ctype nowctype))) + (multiple-value-bind (win sure) + (ctypep value nowctype) + (or (not sure) win)))))))))) + Index: /branches/event-ide/ccl/level-1/l1-unicode.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-unicode.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-unicode.lisp (revision 8262) @@ -360,5 +360,5 @@ ;;; the break is at #x80 instead of #xa0). -(defparameter *iso-8859-2-to-unicode* +(defstatic *iso-8859-2-to-unicode* #( ;; #xa0 @@ -382,5 +382,5 @@ )) -(defparameter *unicode-00a0-0180-to-iso-8859-2* +(defstatic *unicode-00a0-0180-to-iso-8859-2* #( #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 @@ -415,5 +415,5 @@ )) -(defparameter *unicode-00c0-00e0-to-iso-8859-2* +(defstatic *unicode-00c0-00e0-to-iso-8859-2* #( nil nil nil nil nil nil nil #xb7 ; #xc0-#xc7 @@ -527,5 +527,5 @@ ) -(defparameter *iso-8859-3-to-unicode* +(defstatic *iso-8859-3-to-unicode* #( ;; #xa0 @@ -549,5 +549,5 @@ )) -(defparameter *unicode-a0-100-to-iso-8859-3* +(defstatic *unicode-a0-100-to-iso-8859-3* #( #xa0 nil nil #xa3 #xa4 nil nil #xa7 ; #xa0-#xa7 @@ -565,5 +565,5 @@ )) -(defparameter *unicode-108-180-to-iso-8859-3* +(defstatic *unicode-108-180-to-iso-8859-3* #( #xc6 #xe6 #xc5 #xe5 #x00 #x00 #x00 #x00 ; #x108-#x10f @@ -584,5 +584,5 @@ )) -(defparameter *unicode-2d8-2e0-to-iso-8859-3* +(defstatic *unicode-2d8-2e0-to-iso-8859-3* #( #xa2 #xff nil nil nil nil nil nil ; #x2d8-#x2df @@ -707,5 +707,5 @@ -(defparameter *iso-8859-4-to-unicode* +(defstatic *iso-8859-4-to-unicode* #( ;; #xa0 @@ -730,5 +730,5 @@ -(defparameter *unicode-a0-180-to-iso-8859-4* +(defstatic *unicode-a0-180-to-iso-8859-4* #( #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 @@ -762,5 +762,5 @@ )) -(defparameter *unicode-2c0-2e0-to-iso-8859-4* +(defstatic *unicode-2c0-2e0-to-iso-8859-4* #( nil nil nil nil nil nil nil #xb7 ; #x2c0-#x2c7 @@ -878,5 +878,5 @@ ) -(defparameter *iso-8859-5-to-unicode* +(defstatic *iso-8859-5-to-unicode* #( ;; #xa0 @@ -901,5 +901,5 @@ -(defparameter *unicode-a0-b0-to-iso-8859-5* +(defstatic *unicode-a0-b0-to-iso-8859-5* #( #xa0 nil nil nil nil nil nil #xfd ; #xa0-#xa7 @@ -907,5 +907,5 @@ )) -(defparameter *unicode-400-460-to-iso-8859-5* +(defstatic *unicode-400-460-to-iso-8859-5* #( nil #xa1 #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #x400-#x407 @@ -1030,5 +1030,5 @@ ) -(defparameter *iso-8859-6-to-unicode* +(defstatic *iso-8859-6-to-unicode* #( ;; #xa0 @@ -1052,5 +1052,5 @@ )) -(defparameter *unicode-a0-b0-to-iso-8859-6* +(defstatic *unicode-a0-b0-to-iso-8859-6* #( 0xa0 nil nil nil 0xa4 nil nil nil ; #xa0-#xa7 @@ -1059,5 +1059,5 @@ -(defparameter *unicode-608-658-to-iso-8859-6* +(defstatic *unicode-608-658-to-iso-8859-6* #( nil nil nil nil #xac nil nil nil ; #x608-#x60f @@ -1179,5 +1179,5 @@ ) -(defparameter *iso-8859-7-to-unicode* +(defstatic *iso-8859-7-to-unicode* #( ;; #xa0 @@ -1201,5 +1201,5 @@ )) -(defparameter *unicode-a0-c0-to-iso-8859-7* +(defstatic *unicode-a0-c0-to-iso-8859-7* #( #xa0 nil nil #xa3 nil nil #xa6 #xa7 ; #xa0-#xa7 @@ -1209,5 +1209,5 @@ )) -(defparameter *unicode-378-3d0-to-iso-8859-7* +(defstatic *unicode-378-3d0-to-iso-8859-7* #( nil nil #xaa nil nil nil nil nil ; #x378-#x37f @@ -1224,5 +1224,5 @@ )) -(defparameter *unicode-2010-2020-to-iso-8859-7* +(defstatic *unicode-2010-2020-to-iso-8859-7* #( nil nil nil nil nil #xaf nil nil ; #x2010-#x2017 @@ -1230,5 +1230,5 @@ )) -(defparameter *unicode-20ac-20b0-to-iso-8859-7* +(defstatic *unicode-20ac-20b0-to-iso-8859-7* #( #xa4 nil nil #xa5 @@ -1359,5 +1359,5 @@ ) -(defparameter *iso-8859-8-to-unicode* +(defstatic *iso-8859-8-to-unicode* #( ;; #xa0 @@ -1381,5 +1381,5 @@ )) -(defparameter *unicode-a0-f8-to-iso-8859-8* +(defstatic *unicode-a0-f8-to-iso-8859-8* #( #xa0 nil #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #xa0-#xa7 @@ -1396,5 +1396,5 @@ )) -(defparameter *unicode-5d0-5f0-to-iso-8859-8* +(defstatic *unicode-5d0-5f0-to-iso-8859-8* #( #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x5d0-#x5d7 @@ -1404,5 +1404,5 @@ )) -(defparameter *unicode-2008-2018-to-iso-8859-8* +(defstatic *unicode-2008-2018-to-iso-8859-8* #( nil nil nil nil nil nil #xfd #xfe ; #x2008-#x200f @@ -1525,5 +1525,5 @@ ) -(defparameter *iso-8859-9-to-unicode* +(defstatic *iso-8859-9-to-unicode* #( ;; #xd0 @@ -1538,5 +1538,5 @@ )) -(defparameter *unicode-d0-100-to-iso-8859-9* +(defstatic *unicode-d0-100-to-iso-8859-9* #( nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 @@ -1548,5 +1548,5 @@ )) -(defparameter *unicode-118-160-to-iso-8859-9* +(defstatic *unicode-118-160-to-iso-8859-9* #( nil nil nil nil nil nil #xd0 #xf0 ; #x118-#x11f @@ -1668,5 +1668,5 @@ ) -(defparameter *iso-8859-10-to-unicode* +(defstatic *iso-8859-10-to-unicode* #( ;; #xa0 @@ -1690,5 +1690,5 @@ )) -(defparameter *unicode-a0-180-to-iso-8859-10* +(defstatic *unicode-a0-180-to-iso-8859-10* #( #xa0 nil nil nil nil nil nil #xa7 ; #xa0-#xa7 @@ -1930,5 +1930,5 @@ ;;; There is no iso-8859-12 encoding. -(defparameter *iso-8859-13-to-unicode* +(defstatic *iso-8859-13-to-unicode* #( ;; #xa0 @@ -1952,5 +1952,5 @@ )) -(defparameter *unicode-a0-180-to-iso-8859-13* +(defstatic *unicode-a0-180-to-iso-8859-13* #( #xa0 nil #xa2 #xa3 #xa4 nil #xa6 #xa7 ; #xa0-#xa7 @@ -1984,5 +1984,5 @@ )) -(defparameter *unicode-2018-2020-to-iso-8859-13* +(defstatic *unicode-2018-2020-to-iso-8859-13* #( nil #xff nil nil #xb4 #xa1 #xa5 nil ; #x2018-#x201f */ @@ -2098,5 +2098,5 @@ ) -(defparameter *iso-8859-14-to-unicode* +(defstatic *iso-8859-14-to-unicode* #( ;; #xa0 @@ -2120,5 +2120,5 @@ )) -(defparameter *unicode-a0-100-to-iso-8859-14* +(defstatic *unicode-a0-100-to-iso-8859-14* #( #xa0 nil nil #xa3 nil nil nil #xa7 ; #xa0-#xa7 @@ -2136,5 +2136,5 @@ )) -(defparameter *unicode-108-128-to-iso-8859-14* +(defstatic *unicode-108-128-to-iso-8859-14* #( nil nil #xa4 #xa5 nil nil nil nil ; #x108-#x10f @@ -2144,5 +2144,5 @@ )) -(defparameter *unicode-170-180-to-iso-8859-14* +(defstatic *unicode-170-180-to-iso-8859-14* #( nil nil nil nil #xd0 #xf0 #xde #xfe ; #x170-#x177 @@ -2150,5 +2150,5 @@ )) -(defparameter *unicode-1e00-1e88-to-iso-8859-14* +(defstatic *unicode-1e00-1e88-to-iso-8859-14* #( nil nil #xa1 #xa2 nil nil nil nil ; #x1e00-#x1e07 @@ -2171,5 +2171,5 @@ )) -(defparameter *unicode-1ef0-1ef8-to-iso-8859-14* +(defstatic *unicode-1ef0-1ef8-to-iso-8859-14* #( nil nil #xac #xbc nil nil nil nil ; #x1ef0-#x1ef7 @@ -2307,5 +2307,5 @@ ) -(defparameter *iso-8859-15-to-unicode* +(defstatic *iso-8859-15-to-unicode* #( ;; #xa0 @@ -2333,5 +2333,5 @@ )) -(defparameter *unicode-a0-100-to-iso-8859-15* +(defstatic *unicode-a0-100-to-iso-8859-15* #( #xa0 #xa1 #xa2 #xa3 nil #xa5 nil #xa7 ; #xa0-#xa7 @@ -2349,5 +2349,5 @@ )) -(defparameter *unicode-150-180-to-iso-8859-15* +(defstatic *unicode-150-180-to-iso-8859-15* #( nil nil #xbc #xbd nil nil nil nil ; #x150-#x157 @@ -2467,5 +2467,5 @@ ) -(defparameter *iso-8859-16-to-unicode* +(defstatic *iso-8859-16-to-unicode* #( ;; #xa0 @@ -2489,5 +2489,5 @@ )) -(defparameter *unicode-a0-180-to-iso-8859-16* +(defstatic *unicode-a0-180-to-iso-8859-16* #( #xa0 nil nil nil nil nil nil #xa7 ; #xa0-#xa7 @@ -2521,10 +2521,10 @@ )) -(defparameter *unicode-218-220-to-iso-8859-16* +(defstatic *unicode-218-220-to-iso-8859-16* #( #xaa #xba #xde #xfe nil nil nil nil ; #x218-#x21f )) -(defparameter *unicode-2018-2020-to-iso-8859-16* +(defstatic *unicode-2018-2020-to-iso-8859-16* #( nil nil nil nil nil #xb5 #xa5 nil ; #x2018-#x201f @@ -2648,4 +2648,270 @@ ) +(defstatic *macintosh-to-unicode* + #( + ;; #x80 + #\u+00c4 #\u+00c5 #\u+00c7 #\u+00c9 #\u+00d1 #\u+00d6 #\u+00dc #\u+00e1 + #\u+00e0 #\u+00e2 #\u+00e4 #\u+00e3 #\u+00e5 #\u+00e7 #\u+00e9 #\u+00e8 + ;; #x90 + #\u+00ea #\u+00eb #\u+00ed #\u+00ec #\u+00ee #\u+00ef #\u+00f1 #\u+00f3 + #\u+00f2 #\u+00f4 #\u+00f6 #\u+00f5 #\u+00fa #\u+00f9 #\u+00fb #\u+00fc + ;; #xa0 + #\u+2020 #\u+00b0 #\u+00a2 #\u+00a3 #\u+00a7 #\u+2022 #\u+00b6 #\u+00df + #\u+00ae #\u+00a9 #\u+2122 #\u+00b4 #\u+00a8 #\u+2260 #\u+00c6 #\u+00d8 + ;; #xb0 + #\u+221e #\u+00b1 #\u+2264 #\u+2265 #\u+00a5 #\u+00b5 #\u+2202 #\u+2211 + #\u+220f #\u+03c0 #\u+222b #\u+00aa #\u+00ba #\u+2126 #\u+00e6 #\u+00f8 + ;; #xc0 + #\u+00bf #\u+00a1 #\u+00ac #\u+221a #\u+0192 #\u+2248 #\u+2206 #\u+00ab + #\u+00bb #\u+2026 #\u+00a0 #\u+00c0 #\u+00c3 #\u+00d5 #\u+0152 #\u+0153 + ;; #xd0 + #\u+2013 #\u+2014 #\u+201c #\u+201d #\u+2018 #\u+2019 #\u+00f7 #\u+25ca + #\u+00ff #\u+0178 #\u+2044 #\u+00a4 #\u+2039 #\u+203a #\u+fb01 #\u+fb02 + ;; #xe0 + #\u+2021 #\u+00b7 #\u+201a #\u+201e #\u+2030 #\u+00c2 #\u+00ca #\u+00c1 + #\u+00cb #\u+00c8 #\u+00cd #\u+00ce #\u+00cf #\u+00cc #\u+00d3 #\u+00d4 + ;; #xf0 + #\u+f8ff #\u+00d2 #\u+00da #\u+00db #\u+00d9 #\u+0131 #\u+02c6 #\u+02dc + #\u+00af #\u+02d8 #\u+02d9 #\u+02da #\u+00b8 #\u+02dd #\u+02db #\u+02c7 + )) + + +(defstatic *unicode-a0-100-to-macintosh* + #( + #xca #xc1 #xa2 #xa3 #xdb #xb4 nil #xa4 ; #xa0-#xa7 + #xac #xa9 #xbb #xc7 #xc2 nil #xa8 #xf8 ; #xa8-#xaf + #xa1 #xb1 nil nil #xab #xb5 #xa6 #xe1 ; #xb0-#xb7 + #xfc nil #xbc #xc8 nil nil nil #xc0 ; #xb8-#xbf + #xcb #xe7 #xe5 #xcc #x80 #x81 #xae #x82 ; #xc0-#xc7 + #xe9 #x83 #xe6 #xe8 #xed #xea #xeb #xec ; #xc8-#xcf + nil #x84 #xf1 #xee #xef #xcd #x85 nil ; #xd0-#xd7 + #xaf #xf4 #xf2 #xf3 #x86 nil nil #xa7 ; #xd8-#xdf + #x88 #x87 #x89 #x8b #x8a #x8c #xbe #x8d ; #xe0-#xe7 + #x8f #x8e #x90 #x91 #x93 #x92 #x94 #x95 ; #xe8-#xef + nil #x96 #x98 #x97 #x99 #x9b #x9a #xd6 ; #xf0-#xf7 + #xbf #x9d #x9c #x9e #x9f nil nil #xd8 ; #xf8-#xff + )) + +(defstatic *unicode-130-198-to-macintosh* + #( + nil #xf5 nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil #xce #xcf nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + nil nil nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + #xd9 nil nil nil nil nil nil nil ; #x178-#x17f + nil nil nil nil nil nil nil nil ; #x180-#x187 + nil nil nil nil nil nil nil nil ; #x188-#x18f + nil nil #xc4 nil nil nil nil nil ; #x190-#x197 + )) + +(defstatic *unicode-2c0-2e0-to-macintosh* + #( + nil nil nil nil nil nil #xf6 #xff ; #x2c0-#x2c7 + nil nil nil nil nil nil nil nil ; #x2c8-#x2cf + nil nil nil nil nil nil nil nil ; #x2d0-#x2d7 + #xf9 #xfa #xfb #xfe #xf7 #xfd nil nil ; #x2d8-#x2df + )) + +(defstatic *unicode-2010-2048-to-macintosh* + #( + nil nil nil #xd0 #xd1 nil nil nil ; #x2010-#x2017 + #xd4 #xd5 #xe2 nil #xd2 #xd3 #xe3 nil ; #x2018-#x201f + #xa0 #xe0 #xa5 nil nil nil #xc9 nil ; #x2020-#x2027 + nil nil nil nil nil nil nil nil ; #x2028-#x202f + #xe4 nil nil nil nil nil nil nil ; #x2030-#x2037 + nil #xdc #xdd nil nil nil nil nil ; #x2038-#x203f + nil nil nil nil #xda nil nil nil ; #x2040-#x2047 + )) + +(defstatic *unicode-2120-2128-to-macintosh* + #( + nil nil #xaa nil nil nil #xbd nil ; #x2120-#x2127 + )) + +(defstatic *unicode-2200-2268-to-macintosh* + #( + nil nil #xb6 nil nil nil #xc6 nil ; #x2200-#x2207 + nil nil nil nil nil nil nil #xb8 ; #x2208-#x220f + nil #xb7 nil nil nil nil nil nil ; #x2210-#x2217 + nil nil #xc3 nil nil nil #xb0 nil ; #x2218-#x221f + nil nil nil nil nil nil nil nil ; #x2220-#x2227 + nil nil nil #xba nil nil nil nil ; #x2228-#x222f + nil nil nil nil nil nil nil nil ; #x2230-#x2237 + nil nil nil nil nil nil nil nil ; #x2238-#x223f + nil nil nil nil nil nil nil nil ; #x2240-#x2247 + #xc5 nil nil nil nil nil nil nil ; #x2248-#x224f + nil nil nil nil nil nil nil nil ; #x2250-#x2257 + nil nil nil nil nil nil nil nil ; #x2258-#x225f + #xad nil nil nil #xb2 #xb3 nil nil ; #x2260-#x2267 + )) + +(defstatic *unicode-fb00-fb08-to-macintosh* + #( + nil #xde #xdf nil nil nil nil nil ; #xfb00-#xfb07 + )) + +(define-character-encoding :macintosh + "An 8-bit, fixed-width character encoding in which codes #x00-#x7f +map to their Unicode equivalents and other codes map to other Unicode +character values. Traditionally used on Classic MacOS to encode characters +used in western languages." + :aliases '(:macos-roman :macosroman :mac-roman :macroman) + + :stream-encode-function + (nfunction + macintosh-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + macintosh-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80)))))) + :vector-encode-function + (nfunction + macintosh-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + macintosh-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80))))))))) + :memory-encode-function + (nfunction + macintosh-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + macintosh-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + ) ;;; UTF-8. Decoding checks for malformed sequences; it might be faster (and @@ -2862,121 +3128,9 @@ (setf (schar string i) (or char #\Replacement_Character))))))) :memory-encode-function - (nfunction - utf-8-memory-encode - (lambda (string pointer idx start end) - (declare (fixnum idx)) - (do* ((i start (1+ i))) - ((>= i end) idx) - (let* ((code (char-code (schar string i)))) - (declare (type (mod #x110000) code)) - (cond ((< code #x80) - (setf (%get-unsigned-byte pointer idx) code) - (incf idx)) - ((< code #x800) - (setf (%get-unsigned-byte pointer idx) - (logior #xc0 (the fixnum (ash code -6)))) - (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) - (logior #x80 (the fixnum (logand code #x3f)))) - (incf idx 2)) - ((< code #x10000) - (setf (%get-unsigned-byte pointer idx) - (logior #xe0 (the fixnum (ash code -12)))) - (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) - (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) - (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) - (logior #x80 (the fixnum (logand code #x3f)))) - (incf idx 3)) - (t - (setf (%get-unsigned-byte pointer idx) - (logior #xf0 - (the fixnum (logand #x7 (the fixnum (ash code -18)))))) - (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) - (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) - (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) - (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) - (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) - (logand #x3f code)) - (incf idx 4))))))) + #'utf-8-memory-encode :memory-decode-function - (nfunction - utf-8-memory-decode - (lambda (pointer noctets idx string) - (declare (fixnum noctets idx)) - (do* ((i 0 (1+ i)) - (end (+ idx noctets)) - (index idx (1+ index))) - ((>= index end) (if (= index end) index 0)) - (let* ((1st-unit (%get-unsigned-byte pointer index))) - (declare (type (unsigned-byte 8) 1st-unit)) - (let* ((char (if (< 1st-unit #x80) - (code-char 1st-unit) - (if (>= 1st-unit #xc2) - (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) - (declare (type (unsigned-byte 8) 2nd-unit)) - (if (< 1st-unit #xe0) - (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) - (code-char - (logior - (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) - (the fixnum (logxor 2nd-unit #x80))))) - (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) - (declare (type (unsigned-byte 8) 3rd-unit)) - (if (< 1st-unit #xf0) - (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) - (< (the fixnum (logxor 3rd-unit #x80)) #x40) - (or (>= 1st-unit #xe1) - (>= 2nd-unit #xa0))) - (code-char (the fixnum - (logior (the fixnum - (ash (the fixnum (logand 1st-unit #xf)) - 12)) - (the fixnum - (logior - (the fixnum - (ash (the fixnum (logand 2nd-unit #x3f)) - 6)) - (the fixnum (logand 3rd-unit #x3f)))))))) - (if (< 1st-unit #xf8) - (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) - (declare (type (unsigned-byte 8) 4th-unit)) - (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) - (< (the fixnum (logxor 3rd-unit #x80)) #x40) - (< (the fixnum (logxor 4th-unit #x80)) #x40) - (or (>= 1st-unit #xf1) - (>= 2nd-unit #x90))) - (code-char - (logior - (the fixnum - (logior - (the fixnum - (ash (the fixnum (logand 1st-unit 7)) 18)) - (the fixnum - (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) - (the fixnum - (logior - (the fixnum - (ash (the fixnum (logxor 3rd-unit #x80)) 6)) - (the fixnum (logxor 4th-unit #x80))))))))))))))))) - (setf (schar string i) (or char #\Replacement_Character))))))) + #'utf-8-memory-decode :octets-in-string-function - (nfunction - utf-8-octets-in-string - (lambda (string start end) - (if (>= end start) - (do* ((noctets 0) - (i start (1+ i))) - ((= i end) noctets) - (declare (fixnum noctets)) - (let* ((code (char-code (schar string i)))) - (declare (type (mod #x110000) code)) - (incf noctets - (if (< code #x80) - 1 - (if (< code #x800) - 2 - (if (< code #x10000) - 3 - 4)))))) - 0))) + #'utf-8-octets-in-string :length-of-vector-encoding-function (nfunction @@ -2999,20 +3153,5 @@ (setq nchars (1+ nchars) i nexti)))))) :length-of-memory-encoding-function - (nfunction - utf-8-length-of-memory-encoding - (lambda (pointer noctets start) - (do* ((i start) - (end (+ start noctets)) - (nchars 0 (1+ nchars))) - ((= i end) (values nchars i)) - (let* ((code (%get-unsigned-byte pointer i)) - (nexti (+ i (cond ((< code #x80) 1) - ((< code #xe0) 2) - ((< code #xf0) 3) - (t 4))))) - (declare (type (unsigned-byte 8) code)) - (if (> nexti end) - (return (values nchars i)) - (setq i nexti)))))) + #'utf-8-length-of-memory-encoding :decode-literal-code-unit-limit #x80 :encode-literal-char-code-limit #x80 @@ -4651,2 +4790,1516 @@ data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s)))))))) + + + + +;;; This is an array of 256 integers, that (sparsely) encodes 64K bits. +;;; (There might be as many as 256 significant bits in some of entries +;;; in this table.) +(defstatic *bmp-combining-bitmap* + #( + #x00 + #x00 + #x00 + #xFFFF0000FFFFFFFFFFFFFFFFFFFF + #x37800000000000000000000000000000000 + #x16BBFFFFFBFFFE000000000000000000000000000000000000 + #x3D9FFFC00000000000000000000000010000003FF8000000000000000000 + #x1FFC00000000000000000000007FFFFFF000000020000 + + #x00 + #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E + #x3BBFD00000000000000E0003000000003987D000000000000004 + #x803DC7C0000000000000040000000000C0398FD00000000000000E + #x603DDFC00000000000000C0000000000603DDFC00000000000000E + #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C + #x3F001BF20000000000000000000000007F8007F2000000000000 + #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000 + + #x3C0000003C7F00000000000 + #x7FFFFFF0000000000003FFFFE000000000000000000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000 + + #x2000000000000000000000000000000000000003800 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x7FFFFFF0000000000000000000000000000000000000000000000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x600000000000000000000000000FC0000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x40000000 + #x00 + #x00 + #xF0000FFFF + #x00)) + +(defun is-combinable (char) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (when (< code #x1000) + (logbitp (ldb (byte 8 0) code) + (svref *bmp-combining-bitmap* (ldb (byte 8 8) code)))))) + +(defstatic *bmp-combining-chars* + #(#\Combining_Grave_Accent + #\Combining_Acute_Accent + #\Combining_Circumflex_Accent + #\Combining_Tilde + #\Combining_Macron + #\Combining_Breve + #\Combining_Dot_Above + #\Combining_Diaeresis + #\Combining_Hook_Above + #\Combining_Ring_Above + #\Combining_Double_Acute_Accent + #\Combining_Caron + #\Combining_Double_Grave_Accent + #\Combining_Inverted_Breve + #\Combining_Comma_Above + #\Combining_Reversed_Comma_Above + #\Combining_Horn + #\Combining_Dot_Below + #\Combining_Diaeresis_Below + #\Combining_Ring_Below + #\Combining_Comma_Below + #\Combining_Cedilla + #\Combining_Ogonek + #\Combining_Circumflex_Accent_Below + #\Combining_Breve_Below + #\Combining_Tilde_Below + #\Combining_Macron_Below + #\Combining_Long_Solidus_Overlay + #\Combining_Greek_Perispomeni + #\Combining_Greek_Ypogegrammeni + #\Arabic_Maddah_Above + #\Arabic_Hamza_Above + #\Arabic_Hamza_Below + #\U+093C + #\U+09BE + #\U+09D7 + #\U+0B3E + #\U+0B56 + #\U+0B57 + #\U+0BBE + #\U+0BD7 + #\U+0C56 + #\U+0CC2 + #\U+0CD5 + #\U+0CD6 + #\U+0D3E + #\U+0D57 + #\U+0DCA + #\U+0DCF + #\U+0DDF + #\U+102E + #\U+3099 + #\U+309A)) + +(defstatic *bmp-combining-base-chars* + #( + ;; #\Combining_Grave_Accent + + #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y + #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Macron + #\Latin_Small_Letter_E_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I + #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01 + #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 + #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 + #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 + #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Acute_Accent + + #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z + #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z + #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae + #\Latin_Capital_Letter_C_With_Cedilla + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_I_With_Diaeresis + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_O_With_Stroke + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae + #\Latin_Small_Letter_C_With_Cedilla + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_I_With_Diaeresis + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Macron + #\Latin_Small_Letter_E_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde + #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe + #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe + #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09 + #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28 + #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41 + #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 + #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Circumflex_Accent + + #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g + #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8 + #\U+1EB9 #\U+1ECC #\U+1ECD) + + + ;; #\Combining_Tilde + + #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y + #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Macron + + #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y + #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_O_With_Diaeresis + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae + #\Latin_Small_Letter_O_With_Tilde + #\Latin_Small_Letter_O_With_Diaeresis + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_O_With_Ogonek + #\Latin_Small_Letter_O_With_Ogonek + #\Latin_Capital_Letter_A_With_Dot_Above + #\Latin_Small_Letter_A_With_Dot_Above + #\Latin_Capital_Letter_O_With_Dot_Above + #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I + #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I + #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B) + + + ;; #\Combining_Breve + + #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u + #\Latin_Capital_Letter_E_With_Cedilla + #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A + #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe + #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U + #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie + #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I + #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1) + + + ;; #\Combining_Dot_Above + + #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W + #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s + #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute + #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron + #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62 + #\U+1E63) + + + ;; #\Combining_Diaeresis + + #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w + #\x #\y #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron + #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol + #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I + #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie + #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze + #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O + #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che + #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E + #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie + #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze + #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O + #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che + #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E + #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I + #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa + #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O) + + + ;; #\Combining_Hook_Above + + #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y + #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Ring_Above + + #(#\A #\U #\a #\u #\w #\y) + + + ;; #\Combining_Double_Acute_Accent + + #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U + #\Cyrillic_Small_Letter_U) + + + ;; #\Combining_Caron + + #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a + #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh + #\Latin_Small_Letter_Ezh) + + + ;; #\Combining_Double_Grave_Accent + + #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u + #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa) + + + ;; #\Combining_Inverted_Breve + + #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u) + + + ;; #\Combining_Comma_Above + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon + #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho + #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) + + + ;; #\Combining_Reversed_Comma_Above + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon + #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho + #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) + + + ;; #\Combining_Horn + + #(#\O #\U #\o #\u) + + + ;; #\Combining_Dot_Below + + #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W + #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u + #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Diaeresis_Below + + #(#\U #\u) + + + ;; #\Combining_Ring_Below + + #(#\A #\a) + + + ;; #\Combining_Comma_Below + + #(#\S #\T #\s #\t) + + + ;; #\Combining_Cedilla + + #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k + #\l #\n #\r #\s #\t) + + + ;; #\Combining_Ogonek + + #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u) + + + ;; #\Combining_Circumflex_Accent_Below + + #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u) + + + ;; #\Combining_Breve_Below + + #(#\H #\h) + + + ;; #\Combining_Tilde_Below + + #(#\E #\I #\U #\e #\i #\u) + + + ;; #\Combining_Macron_Below + + #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z) + + + ;; #\Combining_Long_Solidus_Overlay + + #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4 + #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243 + #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272 + #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D + #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2 + #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5) + + + ;; #\Combining_Greek_Perispomeni + + #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta + #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08 + #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 + #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 + #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Greek_Ypogegrammeni + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos + #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega + #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02 + #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09 + #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20 + #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27 + #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E + #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65 + #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C + #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6 + #\U+1FC6 #\U+1FF6) + + + ;; #\Arabic_Maddah_Above + + #(#\Arabic_Letter_Alef) + + + ;; #\Arabic_Hamza_Above + + #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh + #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree + #\Arabic_Letter_Ae) + + + ;; #\Arabic_Hamza_Below + + #(#\Arabic_Letter_Alef) + + + ;; #\U+093C + + #(#\U+0928 #\U+0930 #\U+0933) + + + ;; #\U+09BE + + #(#\U+09C7) + + + ;; #\U+09D7 + + #(#\U+09C7) + + + ;; #\U+0B3E + + #(#\U+0B47) + + + ;; #\U+0B56 + + #(#\U+0B47) + + + ;; #\U+0B57 + + #(#\U+0B47) + + + ;; #\U+0BBE + + #(#\U+0BC6 #\U+0BC7) + + + ;; #\U+0BD7 + + #(#\U+0B92 #\U+0BC6) + + + ;; #\U+0C56 + + #(#\U+0C46) + + + ;; #\U+0CC2 + + #(#\U+0CC6) + + + ;; #\U+0CD5 + + #(#\U+0CBF #\U+0CC6 #\U+0CCA) + + + ;; #\U+0CD6 + + #(#\U+0CC6) + + + ;; #\U+0D3E + + #(#\U+0D46 #\U+0D47) + + + ;; #\U+0D57 + + #(#\U+0D46) + + + ;; #\U+0DCA + + #(#\U+0DD9 #\U+0DDC) + + + ;; #\U+0DCF + + #(#\U+0DD9) + + + ;; #\U+0DDF + + #(#\U+0DD9) + + + ;; #\U+102E + + #(#\U+1025) + + + ;; #\U+3099 + + #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055 + #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064 + #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B + #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3 + #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1 + #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8 + #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD) + + + ;; #\U+309A + + #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2 + #\U+30D5 #\U+30D8 #\U+30DB) + )) + +(defstatic *bmp-precombined-chars* + #( + + ;; #\Combining_Grave_Accent + + #(#\Latin_Capital_Letter_A_With_Grave + #\Latin_Capital_Letter_E_With_Grave + #\Latin_Capital_Letter_I_With_Grave + #\Latin_Capital_Letter_N_With_Grave + #\Latin_Capital_Letter_O_With_Grave + #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2 + #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave + #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave + #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave + #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2 + #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1 + #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0 + #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD + #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8 + #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78 + #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2 + #\Cyrillic_Capital_Letter_Ie_With_Grave + #\Cyrillic_Capital_Letter_I_With_Grave + #\Cyrillic_Small_Letter_Ie_With_Grave + #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A + #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23 + #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42 + #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62 + #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD) + + + ;; #\Combining_Acute_Accent + + #(#\Latin_Capital_Letter_A_With_Acute + #\Latin_Capital_Letter_C_With_Acute + #\Latin_Capital_Letter_E_With_Acute + #\Latin_Capital_Letter_G_With_Acute + #\Latin_Capital_Letter_I_With_Acute #\U+1E30 + #\Latin_Capital_Letter_L_With_Acute #\U+1E3E + #\Latin_Capital_Letter_N_With_Acute + #\Latin_Capital_Letter_O_With_Acute #\U+1E54 + #\Latin_Capital_Letter_R_With_Acute + #\Latin_Capital_Letter_S_With_Acute + #\Latin_Capital_Letter_U_With_Acute #\U+1E82 + #\Latin_Capital_Letter_Y_With_Acute + #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute + #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute + #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute + #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F + #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute + #\U+1E55 #\Latin_Small_Letter_R_With_Acute + #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute + #\U+1E83 #\Latin_Small_Letter_Y_With_Acute + #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4 + #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute + #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E + #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute + #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5 + #\Latin_Small_Letter_A_With_Ring_Above_And_Acute + #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1 + #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute + #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF + #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA + #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos + #\Greek_Capital_Letter_Epsilon_With_Tonos + #\Greek_Capital_Letter_Eta_With_Tonos + #\Greek_Capital_Letter_Iota_With_Tonos + #\Greek_Capital_Letter_Omicron_With_Tonos + #\Greek_Capital_Letter_Upsilon_With_Tonos + #\Greek_Capital_Letter_Omega_With_Tonos + #\Greek_Small_Letter_Alpha_With_Tonos + #\Greek_Small_Letter_Epsilon_With_Tonos + #\Greek_Small_Letter_Eta_With_Tonos + #\Greek_Small_Letter_Iota_With_Tonos + #\Greek_Small_Letter_Omicron_With_Tonos + #\Greek_Small_Letter_Upsilon_With_Tonos + #\Greek_Small_Letter_Omega_With_Tonos + #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos + #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos + #\Greek_Upsilon_With_Acute_And_Hook_Symbol + #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje + #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04 + #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D + #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C + #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55 + #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE) + + + ;; #\Combining_Circumflex_Accent + + #(#\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_C_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_G_With_Circumflex + #\Latin_Capital_Letter_H_With_Circumflex + #\Latin_Capital_Letter_I_With_Circumflex + #\Latin_Capital_Letter_J_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_S_With_Circumflex + #\Latin_Capital_Letter_U_With_Circumflex + #\Latin_Capital_Letter_W_With_Circumflex + #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90 + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_C_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_G_With_Circumflex + #\Latin_Small_Letter_H_With_Circumflex + #\Latin_Small_Letter_I_With_Circumflex + #\Latin_Small_Letter_J_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_S_With_Circumflex + #\Latin_Small_Letter_U_With_Circumflex + #\Latin_Small_Letter_W_With_Circumflex + #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD + #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9) + + + ;; #\Combining_Tilde + + #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC + #\Latin_Capital_Letter_I_With_Tilde + #\Latin_Capital_Letter_N_With_Tilde + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8 + #\Latin_Small_Letter_A_With_Tilde #\U+1EBD + #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde + #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde + #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5 + #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF) + + + ;; #\Combining_Macron + + #(#\Latin_Capital_Letter_A_With_Macron + #\Latin_Capital_Letter_E_With_Macron #\U+1E20 + #\Latin_Capital_Letter_I_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Capital_Letter_U_With_Macron + #\Latin_Capital_Letter_Y_With_Macron + #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron + #\U+1E21 #\Latin_Small_Letter_I_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron + #\Latin_Small_Letter_Y_With_Macron + #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_Ae_With_Macron + #\Latin_Capital_Letter_O_With_Tilde_And_Macron + #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron + #\Latin_Small_Letter_A_With_Diaeresis_And_Macron + #\Latin_Small_Letter_Ae_With_Macron + #\Latin_Small_Letter_O_With_Tilde_And_Macron + #\Latin_Small_Letter_O_With_Diaeresis_And_Macron + #\Latin_Small_Letter_U_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_O_With_Ogonek_And_Macron + #\Latin_Small_Letter_O_With_Ogonek_And_Macron + #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron + #\Latin_Small_Letter_A_With_Dot_Above_And_Macron + #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron + #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9 + #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1 + #\Cyrillic_Capital_Letter_I_With_Macron + #\Cyrillic_Capital_Letter_U_With_Macron + #\Cyrillic_Small_Letter_I_With_Macron + #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C + #\U+1E5D) + + + ;; #\Combining_Breve + + #(#\Latin_Capital_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Breve + #\Latin_Capital_Letter_G_With_Breve + #\Latin_Capital_Letter_I_With_Breve + #\Latin_Capital_Letter_O_With_Breve + #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve + #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve + #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8 + #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0 + #\Cyrillic_Capital_Letter_A_With_Breve + #\Cyrillic_Capital_Letter_Ie_With_Breve + #\Cyrillic_Capital_Letter_Zhe_With_Breve + #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U + #\Cyrillic_Small_Letter_A_With_Breve + #\Cyrillic_Small_Letter_Ie_With_Breve + #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I + #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7) + + + ;; #\Combining_Dot_Above + + #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02 + #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A + #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E + #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22 + #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44 + #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60 + #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E + #\Latin_Capital_Letter_Z_With_Dot_Above + #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03 + #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B + #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F + #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45 + #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61 + #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F + #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66 + #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69) + + + ;; #\Combining_Diaeresis + + #(#\Latin_Capital_Letter_A_With_Diaeresis + #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26 + #\Latin_Capital_Letter_I_With_Diaeresis + #\Latin_Capital_Letter_O_With_Diaeresis + #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C + #\Latin_Capital_Letter_Y_With_Diaeresis + #\Latin_Small_Letter_A_With_Diaeresis + #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27 + #\Latin_Small_Letter_I_With_Diaeresis + #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97 + #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D + #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A + #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika + #\Greek_Capital_Letter_Upsilon_With_Dialytika + #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol + #\Cyrillic_Capital_Letter_Yi + #\Cyrillic_Capital_Letter_A_With_Diaeresis + #\Cyrillic_Capital_Letter_Io + #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis + #\Cyrillic_Capital_Letter_Ze_With_Diaeresis + #\Cyrillic_Capital_Letter_I_With_Diaeresis + #\Cyrillic_Capital_Letter_O_With_Diaeresis + #\Cyrillic_Capital_Letter_U_With_Diaeresis + #\Cyrillic_Capital_Letter_Che_With_Diaeresis + #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis + #\Cyrillic_Capital_Letter_E_With_Diaeresis + #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io + #\Cyrillic_Small_Letter_Zhe_With_Diaeresis + #\Cyrillic_Small_Letter_Ze_With_Diaeresis + #\Cyrillic_Small_Letter_I_With_Diaeresis + #\Cyrillic_Small_Letter_O_With_Diaeresis + #\Cyrillic_Small_Letter_U_With_Diaeresis + #\Cyrillic_Small_Letter_Che_With_Diaeresis + #\Cyrillic_Small_Letter_Yeru_With_Diaeresis + #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi + #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis + #\Cyrillic_Small_Letter_Schwa_With_Diaeresis + #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis + #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis) + + + ;; #\Combining_Hook_Above + + #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3 + #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2 + #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE + #\U+1EDF #\U+1EEC #\U+1EED) + + + ;; #\Combining_Ring_Above + + #(#\Latin_Capital_Letter_A_With_Ring_Above + #\Latin_Capital_Letter_U_With_Ring_Above + #\Latin_Small_Letter_A_With_Ring_Above + #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99) + + + ;; #\Combining_Double_Acute_Accent + + #(#\Latin_Capital_Letter_O_With_Double_Acute + #\Latin_Capital_Letter_U_With_Double_Acute + #\Latin_Small_Letter_O_With_Double_Acute + #\Latin_Small_Letter_U_With_Double_Acute + #\Cyrillic_Capital_Letter_U_With_Double_Acute + #\Cyrillic_Small_Letter_U_With_Double_Acute) + + + ;; #\Combining_Caron + + #(#\Latin_Capital_Letter_A_With_Caron + #\Latin_Capital_Letter_C_With_Caron + #\Latin_Capital_Letter_D_With_Caron + #\Latin_Capital_Letter_E_With_Caron + #\Latin_Capital_Letter_G_With_Caron + #\Latin_Capital_Letter_H_With_Caron + #\Latin_Capital_Letter_I_With_Caron + #\Latin_Capital_Letter_K_With_Caron + #\Latin_Capital_Letter_L_With_Caron + #\Latin_Capital_Letter_N_With_Caron + #\Latin_Capital_Letter_O_With_Caron + #\Latin_Capital_Letter_R_With_Caron + #\Latin_Capital_Letter_S_With_Caron + #\Latin_Capital_Letter_T_With_Caron + #\Latin_Capital_Letter_U_With_Caron + #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron + #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron + #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron + #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron + #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron + #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron + #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron + #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron + #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron + #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron + #\Latin_Small_Letter_U_With_Diaeresis_And_Caron + #\Latin_Capital_Letter_Ezh_With_Caron + #\Latin_Small_Letter_Ezh_With_Caron) + + + ;; #\Combining_Double_Grave_Accent + + #(#\Latin_Capital_Letter_A_With_Double_Grave + #\Latin_Capital_Letter_E_With_Double_Grave + #\Latin_Capital_Letter_I_With_Double_Grave + #\Latin_Capital_Letter_O_With_Double_Grave + #\Latin_Capital_Letter_R_With_Double_Grave + #\Latin_Capital_Letter_U_With_Double_Grave + #\Latin_Small_Letter_A_With_Double_Grave + #\Latin_Small_Letter_E_With_Double_Grave + #\Latin_Small_Letter_I_With_Double_Grave + #\Latin_Small_Letter_O_With_Double_Grave + #\Latin_Small_Letter_R_With_Double_Grave + #\Latin_Small_Letter_U_With_Double_Grave + #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent + #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent) + + + ;; #\Combining_Inverted_Breve + + #(#\Latin_Capital_Letter_A_With_Inverted_Breve + #\Latin_Capital_Letter_E_With_Inverted_Breve + #\Latin_Capital_Letter_I_With_Inverted_Breve + #\Latin_Capital_Letter_O_With_Inverted_Breve + #\Latin_Capital_Letter_R_With_Inverted_Breve + #\Latin_Capital_Letter_U_With_Inverted_Breve + #\Latin_Small_Letter_A_With_Inverted_Breve + #\Latin_Small_Letter_E_With_Inverted_Breve + #\Latin_Small_Letter_I_With_Inverted_Breve + #\Latin_Small_Letter_O_With_Inverted_Breve + #\Latin_Small_Letter_R_With_Inverted_Breve + #\Latin_Small_Letter_U_With_Inverted_Breve) + + + ;; #\Combining_Comma_Above + + #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00 + #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60) + + + ;; #\Combining_Reversed_Comma_Above + + #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59 + #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5 + #\U+1F51 #\U+1F61) + + + ;; #\Combining_Horn + + #(#\Latin_Capital_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Dot_Below + + #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32 + #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C + #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05 + #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43 + #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F + #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1) + + + ;; #\Combining_Diaeresis_Below + + #(#\U+1E72 #\U+1E73) + + + ;; #\Combining_Ring_Below + + #(#\U+1E00 #\U+1E01) + + + ;; #\Combining_Comma_Below + + #(#\Latin_Capital_Letter_S_With_Comma_Below + #\Latin_Capital_Letter_T_With_Comma_Below + #\Latin_Small_Letter_S_With_Comma_Below + #\Latin_Small_Letter_T_With_Comma_Below) + + + ;; #\Combining_Cedilla + + #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10 + #\Latin_Capital_Letter_E_With_Cedilla + #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28 + #\Latin_Capital_Letter_K_With_Cedilla + #\Latin_Capital_Letter_L_With_Cedilla + #\Latin_Capital_Letter_N_With_Cedilla + #\Latin_Capital_Letter_R_With_Cedilla + #\Latin_Capital_Letter_S_With_Cedilla + #\Latin_Capital_Letter_T_With_Cedilla + #\Latin_Small_Letter_C_With_Cedilla #\U+1E11 + #\Latin_Small_Letter_E_With_Cedilla + #\Latin_Small_Letter_G_With_Cedilla #\U+1E29 + #\Latin_Small_Letter_K_With_Cedilla + #\Latin_Small_Letter_L_With_Cedilla + #\Latin_Small_Letter_N_With_Cedilla + #\Latin_Small_Letter_R_With_Cedilla + #\Latin_Small_Letter_S_With_Cedilla + #\Latin_Small_Letter_T_With_Cedilla) + + + ;; #\Combining_Ogonek + + #(#\Latin_Capital_Letter_A_With_Ogonek + #\Latin_Capital_Letter_E_With_Ogonek + #\Latin_Capital_Letter_I_With_Ogonek + #\Latin_Capital_Letter_O_With_Ogonek + #\Latin_Capital_Letter_U_With_Ogonek + #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek + #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek + #\Latin_Small_Letter_U_With_Ogonek) + + + ;; #\Combining_Circumflex_Accent_Below + + #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13 + #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77) + + + ;; #\Combining_Breve_Below + + #(#\U+1E2A #\U+1E2B) + + + ;; #\Combining_Tilde_Below + + #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75) + + + ;; #\Combining_Macron_Below + + #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E + #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49 + #\U+1E5F #\U+1E6F #\U+1E95) + + + ;; #\Combining_Long_Solidus_Overlay + + #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD + #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226 + #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270 + #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281 + #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2 + #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB + #\U+22EC #\U+22ED) + + + ;; #\Combining_Greek_Perispomeni + + #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7 + #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27 + #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56 + #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF + #\U+1FDF) + + + ;; #\Combining_Greek_Ypogegrammeni + + #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3 + #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84 + #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B + #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92 + #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99 + #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0 + #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7 + #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE + #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7) + + + ;; #\Arabic_Maddah_Above + + #(#\Arabic_Letter_Alef_With_Madda_Above) + + + ;; #\Arabic_Hamza_Above + + #(#\Arabic_Letter_Alef_With_Hamza_Above + #\Arabic_Letter_Waw_With_Hamza_Above + #\Arabic_Letter_Yeh_With_Hamza_Above + #\Arabic_Letter_Heh_Goal_With_Hamza_Above + #\Arabic_Letter_Yeh_Barree_With_Hamza_Above + #\Arabic_Letter_Heh_With_Yeh_Above) + + + ;; #\Arabic_Hamza_Below + + #(#\Arabic_Letter_Alef_With_Hamza_Below) + + + ;; #\U+093C + + #(#\U+0929 #\U+0931 #\U+0934) + + + ;; #\U+09BE + + #(#\U+09CB) + + + ;; #\U+09D7 + + #(#\U+09CC) + + + ;; #\U+0B3E + + #(#\U+0B4B) + + + ;; #\U+0B56 + + #(#\U+0B48) + + + ;; #\U+0B57 + + #(#\U+0B4C) + + + ;; #\U+0BBE + + #(#\U+0BCA #\U+0BCB) + + + ;; #\U+0BD7 + + #(#\U+0B94 #\U+0BCC) + + + ;; #\U+0C56 + + #(#\U+0C48) + + + ;; #\U+0CC2 + + #(#\U+0CCA) + + + ;; #\U+0CD5 + + #(#\U+0CC0 #\U+0CC7 #\U+0CCB) + + + ;; #\U+0CD6 + + #(#\U+0CC8) + + + ;; #\U+0D3E + + #(#\U+0D4A #\U+0D4B) + + + ;; #\U+0D57 + + #(#\U+0D4C) + + + ;; #\U+0DCA + + #(#\U+0DDA #\U+0DDD) + + + ;; #\U+0DCF + + #(#\U+0DDC) + + + ;; #\U+0DDF + + #(#\U+0DDE) + + + ;; #\U+102E + + #(#\U+1026) + + + ;; #\U+3099 + + #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056 + #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065 + #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C + #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4 + #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2 + #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9 + #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE) + + + ;; #\U+309A + + #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4 + #\U+30D7 #\U+30DA #\U+30DD) + )) + +(defun search-char-vector (vector char) + ;; vector is a SIMPLE-VECTOR of chars sorted by char-code. + ;; return the index of char in vector or NIL if not found + (let* ((left 0) + (right (1- (length vector)))) + (declare (fixnum left right)) + (if (and (char>= char (svref vector left)) + (char<= char (svref vector right))) + (do* () + ((> left right)) + (let* ((mid (ash (the fixnum (+ left right)) -1)) + (midch (svref vector mid))) + (declare (fixnum mid)) + (if (eql char midch) + (return mid) + (if (char< char midch) + (setq right (1- mid)) + (setq left (1+ mid))))))))) + + +(defconstant HANGUL-SBASE #xAC00) +(defconstant HANGUL-LBASE #x1100) +(defconstant HANGUL-VBASE #x1161) +(defconstant HANGUL-TBASE #x11A7) + +(defconstant HANGUL-SCOUNT 11172) +(defconstant HANGUL-LCOUNT 19) +(defconstant HANGUL-VCOUNT 21) +(defconstant HANGUL-TCOUNT 28) +(defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT)) + +(defun combine-bmp-chars (base combiner) + (if (and (char>= combiner (code-char hangul-vbase)) + (char< combiner (code-char (+ hangul-tbase hangul-tcount)))) + (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount))) + (char>= base (code-char hangul-lbase)) + (char< base (code-char (+ hangul-lbase hangul-lcount)))) + (return-from combine-bmp-chars + (code-char (+ hangul-lbase + (* hangul-ncount (- (char-code base) hangul-lbase)) + (* hangul-tcount (- (char-code combiner) hangul-vbase)))))) + (if (and (char> combiner (code-char hangul-tbase)) + (char>= base (code-char hangul-sbase)) + (char< base (code-char (+ hangul-sbase hangul-scount)))) + (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount)))) + (return-from combine-bmp-chars nil) + (return-from combine-bmp-chars + (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase))))))) + + (let* ((idx (search-char-vector *bmp-combining-chars* combiner)) + (base-table (if idx (svref *bmp-combining-base-chars* idx)))) + (if base-table + (let* ((combined-idx (search-char-vector base-table base))) + (if combined-idx + (svref (svref *bmp-precombined-chars* idx) combined-idx)))))) + +(defun precompose-simple-string (s) + (let* ((n (length s))) + (or (dotimes (i n s) + (when (is-combinable (schar s i)) + (return nil))) + (let* ((new (make-string n))) + (declare (dynamic-extent new)) + (do* ((i 0 (1+ i)) + (nout -1) + (lastch nil)) + ((= i n) (subseq new 0 (1+ nout))) + (declare (fixnum nout i)) + (let* ((ch (schar s i))) + (if (or (not lastch) + (not (is-combinable ch))) + (setf lastch ch + (schar new (incf nout)) ch) + (let* ((combined (combine-bmp-chars lastch ch))) + (if combined + (setf (schar new nout) (setq lastch combined)) + (setf lastch ch + (schar new (incf nout)) ch)))))))))) Index: /branches/event-ide/ccl/level-1/l1-utils.lisp =================================================================== --- /branches/event-ide/ccl/level-1/l1-utils.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/l1-utils.lisp (revision 8262) @@ -1276,7 +1276,7 @@ (defun %set-composite-pointer-ref (size pointer offset new) - (#_bcopy new - (%inc-ptr pointer offset) - size)) + (#_memmove (%inc-ptr pointer offset) + new + size)) Index: /branches/event-ide/ccl/level-1/linux-files.lisp =================================================================== --- /branches/event-ide/ccl/level-1/linux-files.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/linux-files.lisp (revision 8262) @@ -30,4 +30,19 @@ ) + +(defun get-foreign-namestring (pointer) + ;; On Darwin, foreign namestrings are encoded in UTF-8 and + ;; are canonically decomposed (NFD). Use PRECOMPOSE-SIMPLE-STRING + ;; to ensure that the string is "precomposed" (NFC), like the + ;; rest of the world and most sane people would expect. + #+darwin-target + (precompose-simple-string (%get-utf-8-cstring pointer)) + ;; On some other platforms, the namestring is assumed to + ;; be encoded according to the current locale's character + ;; encoding (though FreeBSD seems to be moving towards + ;; precomposed UTF-8.). + ;; In any case, the use if %GET-CSTRING here is wrong ... + #-darwin-target + (%get-cstring pointer)) (defun nanoseconds (n) @@ -156,5 +171,5 @@ ((< len bufsize) (setf (%get-unsigned-byte buf len) 0) - (values (%get-cstring buf) len)) + (values (get-foreign-namestring buf) len)) (t (values nil len))))))) (do* ((string nil) @@ -176,22 +191,23 @@ (defun %chdir (dirname) - (with-cstrs ((dirname dirname)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname)) (syscall syscalls::chdir dirname))) (defun %mkdir (name mode) - (let* ((last (1- (length name)))) - (with-cstrs ((name name)) - (when (and (>= last 0) - (eql (%get-byte name last) (char-code #\/))) - (setf (%get-byte name last) 0)) - (syscall syscalls::mkdir name mode)))) + (let* ((name name) + (len (length name))) + (when (and (> len 0) (eql (char name (1- len)) #\/)) + (setq name (subseq name 0 (1- len)))) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) + (syscall syscalls::mkdir name mode)))) (defun %rmdir (name) (let* ((last (1- (length name)))) - (with-cstrs ((name name)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name)) (when (and (>= last 0) (eql (%get-byte name last) (char-code #\/))) (setf (%get-byte name last) 0)) (syscall syscalls::rmdir name)))) + (defun getenv (key) @@ -247,5 +263,5 @@ (defun %%stat (name stat) - (with-cstrs ((cname name)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) (%stat-values #+linux-target @@ -264,5 +280,5 @@ (defun %%lstat (name stat) - (with-cstrs ((cname name)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name)) (%stat-values #+linux-target @@ -273,6 +289,8 @@ -;;; Returns: (values t mode size mtime inode uid) on success, -;;; (values nil nil nil nil nil nil) otherwise +;;; Returns: (values t mode size mtime inode uid blksize) on success, +;;; (values nil nil nil nil nil nil nil) otherwise +;;; NAME should be a "native namestring", e.g,, have all lisp pathname +;;; escaping removed. (defun %stat (name &optional link-p) (rlet ((stat :stat)) @@ -298,5 +316,5 @@ (defun %unix-file-kind (path &optional check-for-link) - (%file-kind (nth-value 1 (%stat path check-for-link)))) + (%file-kind (nth-value 1 (%stat (native-translated-namestring path) check-for-link)))) (defun %unix-fd-kind (fd) @@ -377,9 +395,9 @@ (setq namestring (current-directory-name))) (%stack-block ((resultbuf #$PATH_MAX)) - (with-cstrs ((name (tilde-expand namestring))) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring #|(tilde-expand namestring)|#)) (let* ((result (#_realpath name resultbuf))) (declare (dynamic-extent result)) (unless (%null-ptr-p result) - (%get-cstring result)))))) + (get-foreign-namestring result)))))) ;;; Return fully resolved pathname & file kind, or (values nil nil) @@ -395,4 +413,6 @@ (+ (* 1000 (pref tv :timeval.tv_sec)) (round (pref tv :timeval.tv_usec) 1000))) +(defun timeval->microseconds (tv) + (+ (* 1000000 (pref tv :timeval.tv_sec)) (pref tv :timeval.tv_usec))) (defun %add-timevals (result a b) @@ -436,5 +456,5 @@ (defun %utimes (namestring) - (with-cstrs ((cnamestring namestring)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring)) (let* ((err (#_utimes cnamestring (%null-ptr)))) (declare (fixnum err)) @@ -454,5 +474,5 @@ (defun %open-dir (namestring) - (with-cstrs ((name namestring)) + (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring)) (let* ((DIR (#_opendir name))) (unless (%null-ptr-p DIR) @@ -464,6 +484,6 @@ (defun %read-dir (dir) (let* ((res (#_readdir dir))) - (unless (%null-ptr-p res) - (%get-cstring (pref res :dirent.d_name))))) + (unless (%null-ptr-p res) + (get-foreign-namestring (pref res :dirent.d_name))))) (defun tcgetpgrp (fd) @@ -489,5 +509,5 @@ (let* ((err (#_getpwuid_r userid pwd buf buflen result))) (if (eql 0 err) - (return (%get-cstring (pref pwd :passwd.pw_dir))) + (return (get-foreign-namestring (pref pwd :passwd.pw_dir))) (unless (eql err #$ERANGE) (return nil)))))))) @@ -634,22 +654,24 @@ -#+linux-target -(defun pipe () - (%stack-block ((pipes 8)) - (let* ((status (syscall syscalls::pipe pipes))) - (if (= 0 status) - (values (%get-long pipes 0) (%get-long pipes 4)) - (%errno-disp status))))) + ;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd. ;;; Use libc's interface. -#+(or darwin-target freebsd-target) (defun pipe () + ;; (rlet ((filedes (:array :int 2))) (%stack-block ((filedes 8)) - (let* ((status (#_pipe filedes))) + (let* ((status (#_pipe filedes)) + (errno (if (eql status 0) 0 (%get-errno)))) + (unless (zerop status) + (when (or (eql errno (- #$EMFILE)) + (eql errno (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq status (#_pipe filedes) + errno (if (zerop status) 0 (%get-errno))))) (if (zerop status) (values (paref filedes (:array :int) 0) (paref filedes (:array :int) 1)) - (%errno-disp (%get-errno)))))) + (%errno-disp errno))))) @@ -707,5 +729,6 @@ :element-type element-type :interactive nil - :basic t) + :basic t + :auto-close t) (cons read-pipe close-in-parent) (cons write-pipe close-on-error))) @@ -716,5 +739,6 @@ :element-type element-type :interactive nil - :basic t) + :basic t + :auto-close t) (cons write-pipe close-in-parent) (cons read-pipe close-on-error))) @@ -784,4 +808,18 @@ +(defmacro wtermsig (status) + `(ldb (byte 7 0) ,status)) + +(defmacro wexitstatus (status) + `(ldb (byte 8 8) (the fixnum ,status))) + +(defmacro wstopsig (status) + `(wexitstatus ,status)) + +(defmacro wifexited (status) + `(eql (wtermsig ,status) 0)) + +(defmacro wifstopped (status) + `(eql #x7f (ldb (byte 7 0) (the fixnum ,status)))) (defun monitor-external-process (p) @@ -940,18 +978,5 @@ -(defmacro wtermsig (status) - `(ldb (byte 7 0) ,status)) - -(defmacro wexitstatus (status) - `(ldb (byte 8 8) (the fixnum ,status))) - -(defmacro wstopsig (status) - `(wexitstatus ,status)) - -(defmacro wifexited (status) - `(eql (wtermsig ,status) 0)) - -(defmacro wifstopped (status) - `(eql #x7f (ldb (byte 7 0) (the fixnum ,status)))) + (defmacro wifsignaled (status) @@ -1191,5 +1216,6 @@ (if (eql 1 (cpu-count)) (%defglobal '*spin-lock-tries* 1) - (%defglobal '*spin-lock-tries* 1024))) + (%defglobal '*spin-lock-tries* 1024)) + (%defglobal '*spin-lock-timeouts* 0)) (defun yield () Index: /branches/event-ide/ccl/level-1/ppc-error-signal.lisp =================================================================== --- /branches/event-ide/ccl/level-1/ppc-error-signal.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/ppc-error-signal.lisp (revision 8262) @@ -114,5 +114,5 @@ (%kernel-restart-internal $xudfcall - (list (xp-gpr-lisp xp ppc::fname) args) + (list (maybe-setf-name (xp-gpr-lisp xp ppc::fname)) args) frame-ptr))) (stack-argcnt (max 0 (- (length args) 3))) Index: /branches/event-ide/ccl/level-1/sysutils.lisp =================================================================== --- /branches/event-ide/ccl/level-1/sysutils.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/sysutils.lisp (revision 8262) @@ -303,16 +303,18 @@ -;This is like check-type, except it returns the value rather than setf'ing -;anything, and so can be done entirely out-of-line. -(defun require-type (arg type) - (if (typep arg type) +;;; This is like check-type, except it returns the value rather than setf'ing +;;; anything, and so can be done entirely out-of-line. +(defun require-type (arg type) + (multiple-value-bind (win sure) + (ctypep arg (specifier-type type)) + (if (or win (not sure)) + arg + (%kernel-restart $xwrongtype arg type)))) + +;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named) +(defun %require-type (arg predsym) + (if (funcall predsym arg) arg - (%kernel-restart $xwrongtype arg type))) - -; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named) -(defun %require-type (arg predsym) - (if (funcall predsym arg) - arg - (%kernel-restart $xwrongtype arg `(satisfies ,predsym)))) + (%kernel-restart $xwrongtype arg (type-for-predicate predsym)))) (defun %require-type-builtin (arg type-cell) @@ -323,4 +325,14 @@ +;;; In lieu of an inverted mapping, at least try to find cases involving +;;; builtin numeric types and predicates associated with them. +(defun type-for-predicate (pred) + (or (block find + (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype) + (eq (numeric-ctype-predicate ctype) + pred)) + (return-from find type))) + *builtin-type-info*)) + `(satisfies ,pred))) @@ -429,12 +441,18 @@ the string, returns the character object representing the character at that position in the string." - (if (stringp string) - (aref string index) - (report-bad-arg string 'string))) + (if (typep string 'simple-string) + (schar (the simple-string string) index) + (if (stringp string) + (multiple-value-bind (data offset) (array-data-and-offset string) + (schar (the simple-string data) (+ index offset))) + (report-bad-arg string 'string)))) (defun set-char (string index new-el) - (if (stringp string) - (aset string index new-el) - (report-bad-arg string 'string))) + (if (typep string 'simple-string) + (setf (schar string index) new-el) + (if (stringp string) + (multiple-value-bind (data offset) (array-data-and-offset string) + (setf (schar (the simple-string data) (+ index offset)) new-el)) + (report-bad-arg string 'string)))) (defun equalp (x y) @@ -691,5 +709,19 @@ (setq *type-system-initialized* t) - - - +#+count-gf-calls +(progn +;;; Call-counting for generic functions. We overload the +;;; (previously unused +(defmethod generic-function-call-count ((gf generic-function)) + (gf.hash gf)) + + +(defun (setf generic-function-call-count) (count gf) + (setf (gf.hash gf) (require-type count 'fixnum))) + +(defun clear-all-generic-function-call-counts () + (dolist (gf (population.data %all-gfs%)) + (setf (gf.hash gf) 0))) +);#+count-gf-calls + + Index: /branches/event-ide/ccl/level-1/version.lisp =================================================================== --- /branches/event-ide/ccl/level-1/version.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/version.lisp (revision 8262) @@ -18,5 +18,5 @@ (defparameter *openmcl-major-version* 1) -(defparameter *openmcl-minor-version* 1) +(defparameter *openmcl-minor-version* 2) (defparameter *openmcl-revision* 0) ;;; May be set by xload-level-0 @@ -24,5 +24,5 @@ (defparameter *openmcl-dev-level* nil) -(defparameter *openmcl-version* (format nil "~d.~d~@[.~d~]~@[-r~a~] (~@[~A: ~]~~A)" +(defparameter *openmcl-version* (format nil "~d.~d~@[.~d~]~@[-r~a~] ~@[+~s~] (~@[~A: ~]~~A)" *openmcl-major-version* *openmcl-minor-version* @@ -30,4 +30,5 @@ *openmcl-revision*) *openmcl-svn-revision* + *optional-features* *openmcl-dev-level*)) Index: /branches/event-ide/ccl/level-1/x86-error-signal.lisp =================================================================== --- /branches/event-ide/ccl/level-1/x86-error-signal.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/x86-error-signal.lisp (revision 8262) @@ -55,5 +55,5 @@ (%kernel-restart-internal $xudfcall - (list (encoded-gpr-lisp xp x8664::fname) args) + (list (maybe-setf-name (encoded-gpr-lisp xp x8664::fname)) args) frame-ptr))) (f #'(lambda (values) (apply #'values values)))) @@ -73,5 +73,5 @@ (>= op1 #x70)) (cond ((< op1 #x90) - (setq skip 3) + (setq skip (%check-anchored-uuo xcf 3)) (setq *error-reentry-count* 0) (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) @@ -81,4 +81,5 @@ frame-ptr))) ((< op1 #xa0) + (setq skip (%check-anchored-uuo xcf 2)) ;; #x9x - register X is a symbol. It's unbound. (%kernel-restart-internal $xvunbnd @@ -89,4 +90,5 @@ frame-ptr)) ((< op1 #xb0) + (setq skip (%check-anchored-uuo xcf 2)) (%err-disp-internal $xfunbnd (list (encoded-gpr-lisp @@ -95,5 +97,5 @@ frame-ptr)) ((< op1 #xc0) - (setq skip 3) + (setq skip (%check-anchored-uuo xcf 3)) (%err-disp-internal #.(car (rassoc 'type-error *kernel-simple-error-classes*)) @@ -104,4 +106,5 @@ frame-ptr)) ((= op1 #xc0) + (setq skip (%check-anchored-uuo xcf 2)) (%error 'too-few-arguments (list :nargs (xp-argument-count xp) @@ -109,4 +112,5 @@ frame-ptr)) ((= op1 #xc1) + (setq skip (%check-anchored-uuo xcf 2)) (%error 'too-many-arguments (list :nargs (xp-argument-count xp) @@ -114,4 +118,5 @@ frame-ptr)) ((= op1 #xc2) + (setq skip (%check-anchored-uuo xcf 2)) (let* ((flags (xp-flags-register xp)) (nargs (xp-argument-count xp)) @@ -127,4 +132,5 @@ frame-ptr)))) ((= op1 #xc3) ;array rank + (setq skip (%check-anchored-uuo xcf 3)) (%err-disp-internal $XNDIMS (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) @@ -132,4 +138,5 @@ frame-ptr)) ((= op1 #xc6) + (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp xp x8664::temp0) @@ -142,5 +149,5 @@ (setq skip 0)) ((or (= op1 #xc8) (= op1 #xcb)) - (setq skip 3) + (setq skip (%check-anchored-uuo xcf 3)) (%error (%rsc-string $xarroob) (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) @@ -148,4 +155,5 @@ frame-ptr)) ((= op1 #xc9) + (setq skip (%check-anchored-uuo xcf 2)) (%err-disp-internal $xnotfun (list (encoded-gpr-lisp xp x8664::temp0)) @@ -154,5 +162,5 @@ ((= op1 #xcc) ;; external entry point or foreign variable - (setq skip 3) + (setq skip (%check-anchored-uuo xcf 3)) (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) (etypecase eep-or-fv @@ -166,5 +174,5 @@ (fv.addr eep-or-fv)))))) ((< op1 #xe0) - (setq skip 3) + (setq skip (%check-anchored-uuo xcf 3)) (if (= op2 x8664::subtag-catch-frame) (%error (make-condition 'cant-throw-error @@ -202,4 +210,5 @@ frame-ptr)))) ((< op1 #xf0) + (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp @@ -210,4 +219,5 @@ frame-ptr)) (t + (setq skip (%check-anchored-uuo xcf 2)) (%error (make-condition 'type-error :datum (encoded-gpr-lisp Index: /branches/event-ide/ccl/level-1/x86-trap-support.lisp =================================================================== --- /branches/event-ide/ccl/level-1/x86-trap-support.lisp (revision 8261) +++ /branches/event-ide/ccl/level-1/x86-trap-support.lisp (revision 8262) @@ -172,4 +172,18 @@ (%get-unsigned-byte (%int-to-ptr byte-offset) delta)))) +;;; If the byte following a uuo (which is "skip" bytes long, set +;;; the xcf's relative PC to the value contained in the 32-bit +;;; word preceding the current relative PC and return -1, else return skip. +(defun %check-anchored-uuo (xcf skip) + (if (eql 0 (%get-xcf-byte xcf skip)) + (let* ((new-rpc (+ target::tag-function + (logior (ash (%get-xcf-byte xcf -1) 24) + (ash (%get-xcf-byte xcf -2) 16) + (ash (%get-xcf-byte xcf -3) 8) + (%get-xcf-byte xcf -4))))) + (%set-object xcf x8664::xcf.relative-pc new-rpc) + -1) + skip)) + (defun decode-arithmetic-error (xp xcf) @@ -190,5 +204,4 @@ (multiple-value-bind (operation operands) (decode-arithmetic-error xp xcf) - (let* ((condition-name (cond ((or (= code #$FPE_INTDIV) Index: /branches/event-ide/ccl/lib/arglist.lisp =================================================================== --- /branches/event-ide/ccl/lib/arglist.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/arglist.lisp (revision 8262) @@ -185,6 +185,4 @@ (when restp (push (if lexprp '&lexpr '&rest) res) - (when nkeys - (when (> idx nkeys) (decf idx nkeys))) (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res)) (when nkeys (push '&key res) @@ -207,5 +205,6 @@ (keys)) (let* ((rest nil) - (map (car (function-symbol-map lfun)))) + (map (if (> pc target::arg-check-trap-pc-limit) + (car (function-symbol-map lfun))))) (if (and map pc) (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0))) Index: /branches/event-ide/ccl/lib/backtrace.lisp =================================================================== --- /branches/event-ide/ccl/lib/backtrace.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/backtrace.lisp (revision 8262) @@ -96,22 +96,23 @@ (call 'funcall) (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">"))))) - (multiple-value-bind (req opt restp keys) - (function-args lfun) - (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys) - (let* ((arglist (arglist-from-map lfun))) - (if (null arglist) - (call "???") - (progn - (dotimes (i req) - (let* ((val (argument-value context cfp lfun pc (pop arglist)))) - (if (eq val (%unbound-marker)) - (call "?") - (call (let* ((*print-length* *backtrace-print-length*) - (*print-level* *backtrace-print-level*)) - (format nil "~s" val)))))) - (if (or restp keys (not (eql opt 0))) - (call "[...]")) - )))))) - (call))) + (if (<= pc target::arg-check-trap-pc-limit) + (append (call) (arg-check-call-arguments cfp lfun)) + (multiple-value-bind (req opt restp keys) + (function-args lfun) + (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys) + (let* ((arglist (arglist-from-map lfun))) + (if (null arglist) + (call "???") + (progn + (dotimes (i req) + (let* ((val (argument-value context cfp lfun pc (pop arglist)))) + (if (eq val (%unbound-marker)) + (call "?") + (call (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (format nil "~s" val)))))) + (if (or restp keys (not (eql opt 0))) + (call "[...]")))))) + (call)))))) @@ -150,5 +151,6 @@ (unless (and (typep detailed-p 'fixnum) (not (= (the fixnum detailed-p) frame-number))) - (format t "~&(~x) : ~D ~a ~d" + (format t "~&~c(~x) : ~D ~a ~d" + (if (exception-frame-p p) #\* #\space) (index->address p) frame-number (if lfun (backtrace-call-arguments context p lfun pc)) @@ -239,4 +241,23 @@ value))))))) +;;; Returns non-nil on success (not newval) +(defun set-map-entry-value (context cfp lfun pc idx newval) + (declare (fixnum pc idx)) + (let* ((unavailable (cons nil nil)) + (value (map-entry-value context cfp lfun pc idx unavailable))) + (if (eq value unavailable) + nil + (if (typep value 'value-cell) + (progn (setf (uvref value 0) newval) t) + + (let* ((addrs (cdr (function-symbol-map lfun))) + (addr (svref addrs (the fixnum (* 3 idx))))) + (declare (fixnum addr)) + (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval) + (set-register-argument-value context cfp addr newval)) + t))))) + + (defun argument-value (context cfp lfun pc name &optional (quote t)) (declare (fixnum pc)) @@ -274,7 +295,14 @@ (defun raw-frame-ref (cfp context index bad) (%raw-frame-ref cfp context index bad)) + +(defun raw-frame-set (cfp context index new) + (%raw-frame-set cfp context index new)) (defun find-register-argument-value (context cfp regval bad) (%find-register-argument-value context cfp regval bad)) + +(defun set-register-argument-value (context cfp regval newval) + (%set-register-argument-value context cfp regval newval)) + @@ -390,4 +418,58 @@ (push i indices) (push (svref names i) vars)))))))))) + + +(defun arg-value (context cfp lfun pc unavailable name) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (pos (position name vars))) + (if (and pos (< pos nargs)) + (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable) + unavailable)) + unavailable)))) + +(defun local-value (context cfp lfun pc unavailable name) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (names (nthcdr nargs vars)) + (indices (nthcdr nargs map-indices)) + (pos (if (typep name 'unsigned-byte) + name + (position name names :from-end t)))) + (if (and pos (< pos nargs)) + (map-entry-value context cfp lfun pc (nth pos indices) unavailable) + unavailable)) + unavailable)))) + +(defun set-arg-value (context cfp lfun pc name new) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (pos (position name vars))) + (when (and pos (< pos nargs)) + (set-map-entry-value context cfp lfun pc (nth pos map-indices) new))))))) + +(defun set-local-value (context cfp lfun pc name new) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (names (nthcdr nargs vars)) + (indices (nthcdr nargs map-indices)) + (pos (if (typep name 'unsigned-byte) + name + (position name names :from-end t)))) + (if (and pos (< pos nargs)) + (set-map-entry-value context cfp lfun pc (nth pos indices) new))))))) + (defun arguments-and-locals (context cfp lfun pc &optional unavailable) @@ -465,4 +547,18 @@ (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) (setq oldest db))))) + +(defun (setf oldest-binding-frame-value) (new context frame) + (let* ((oldest nil) + (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) + (do* ((db (db-link context) (%fixnum-ref db 0))) + ((eq frame db) + (if oldest + (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new) + (let* ((symbol (binding-index-symbol binding-index))) + (if context + (setf (symbol-value-in-tcr symbol (bt.tcr context)) new) + (%set-sym-value symbol new))))) + (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) + (setq oldest db))))) Index: /branches/event-ide/ccl/lib/ccl-export-syms.lisp =================================================================== --- /branches/event-ide/ccl/lib/ccl-export-syms.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/ccl-export-syms.lisp (revision 8262) @@ -144,4 +144,5 @@ ensure-class-using-class ensure-generic-function-using-class + eql-specializer eql-specializer-object extract-lambda-list @@ -222,4 +223,7 @@ specializer-direct-generic-functions copy-instance + + override-one-method-one-arg-dcode + optimize-generic-function-dispatching ;; Not MOP @@ -389,4 +393,6 @@ *fasl-save-doc-strings* *fasl-save-definitions* + *static-cons-chunk* + static-cons compiler-let @@ -615,4 +621,6 @@ unmap-ivector unmap-octet-vector + ;; Miscellany + heap-utilization ) "CCL" @@ -652,4 +660,5 @@ "ENSURE-CLASS-USING-CLASS" "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" "EQL-SPECIALIZER-OBJECT" "EXTRACT-LAMBDA-LIST" Index: /branches/event-ide/ccl/lib/compile-ccl.lisp =================================================================== --- /branches/event-ide/ccl/lib/compile-ccl.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/compile-ccl.lisp (revision 8262) @@ -193,5 +193,4 @@ arglist edit-callers - hash-cons describe asdf @@ -457,81 +456,90 @@ (:darwinx8664 "darwinx8664"))) -(defun rebuild-ccl (&key full clean kernel force (reload t) exit reload-arguments verbose) - (when full - (setq clean t kernel t reload t)) - (let* ((cd (current-directory))) - (unwind-protect - (progn - (setf (current-directory) "ccl:") - (when clean - (dolist (f (directory - (merge-pathnames - (make-pathname :name :wild - :type (pathname-type *.fasl-pathname*)) - "ccl:**;"))) - (delete-file f))) - (when kernel - (when (or clean force) - ;; Do a "make -k clean". - (run-program "make" - (list "-k" - "-C" - (format nil "lisp-kernel/~a" - (kernel-build-directory)) - "clean"))) - (format t "~&;Building lisp-kernel ...") - (with-output-to-string (s) - (multiple-value-bind - (status exit-code) - (external-process-status - (run-program "make" - (list "-k" "-C" - (format nil "lisp-kernel/~a" - (kernel-build-directory)) - "-j" +(defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait)) +(defvar *build-time-optional-features* nil) + + +(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features) + (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features)) + (*features* (append *build-time-optional-features* *features*))) + (when *build-time-optional-features* + (setq full t)) + (when full + (setq clean t kernel t reload t)) + (when update (update-ccl)) + (let* ((cd (current-directory))) + (unwind-protect + (progn + (setf (current-directory) "ccl:") + (when clean + (dolist (f (directory + (merge-pathnames + (make-pathname :name :wild + :type (pathname-type *.fasl-pathname*)) + "ccl:**;"))) + (delete-file f))) + (when kernel + (when (or clean force) + ;; Do a "make -k clean". + (run-program "make" + (list "-k" + "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "clean"))) + (format t "~&;Building lisp-kernel ...") + (with-output-to-string (s) + (multiple-value-bind + (status exit-code) + (external-process-status + (run-program "make" + (list "-k" "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "-j" - (format nil "~d" (1+ (cpu-count)))) - :output s - :error s)) - (if (and (eq :exited status) (zerop exit-code)) - (progn - (format t "~&;Kernel built successfully.") - (when verbose - (format t "~&;kernel build output:~%~a" - (get-output-stream-string s))) - (sleep 1)) - (error "Error(s) during kernel compilation.~%~a" - (get-output-stream-string s)))))) - (compile-ccl (not (null force))) - (if force (xload-level-0 :force) (xload-level-0)) - (when reload - (with-input-from-string (cmd (format nil - "(save-application ~s)" - (standard-image-name))) - (with-output-to-string (output) - (multiple-value-bind (status exit-code) - (external-process-status - (run-program - (format nil "./~a" (standard-kernel-name)) - (list* "--image-name" (standard-boot-image-name) - reload-arguments) - :input cmd - :output output - :error output)) - (if (and (eq status :exited) - (eql exit-code 0)) + (format nil "~d" (1+ (cpu-count)))) + :output s + :error s)) + (if (and (eq :exited status) (zerop exit-code)) (progn - (format t "~&;Wrote heap image: ~s" - (truename (format nil "ccl:~a" - (standard-image-name)))) + (format t "~&;Kernel built successfully.") (when verbose - (format t "~&;Reload heap image output:~%~a" - (get-output-stream-string output)))) - (error "Errors (~s ~s) reloading boot image:~&~a" - status exit-code - (get-output-stream-string output))))))) - (when exit - (quit))) - (setf (current-directory) cd)))) + (format t "~&;kernel build output:~%~a" + (get-output-stream-string s))) + (sleep 1)) + (error "Error(s) during kernel compilation.~%~a" + (get-output-stream-string s)))))) + (compile-ccl (not (null force))) + (if force (xload-level-0 :force) (xload-level-0)) + (when reload + (with-input-from-string (cmd (format nil + "(save-application ~s)" + (standard-image-name))) + (with-output-to-string (output) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program + (format nil "./~a" (standard-kernel-name)) + (list* "--image-name" (standard-boot-image-name) + reload-arguments) + :input cmd + :output output + :error output)) + (if (and (eq status :exited) + (eql exit-code 0)) + (progn + (format t "~&;Wrote heap image: ~s" + (truename (format nil "ccl:~a" + (standard-image-name)))) + (when verbose + (format t "~&;Reload heap image output:~%~a" + (get-output-stream-string output)))) + (error "Errors (~s ~s) reloading boot image:~&~a" + status exit-code + (get-output-stream-string output))))))) + (when exit + (quit))) + (setf (current-directory) cd))))) @@ -564,2 +572,22 @@ (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]") (funcall f dirname target)))))) + +(defun update-ccl () + (let* ((cvs-update "cvs -q update -d -P") + (svn-update "svn update") + (use-cvs (probe-file "ccl:\.svnrev")) + (s (make-string-output-stream))) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "/bin/sh" + (list "-c" + (format nil "cd ~a && ~a" + (native-translated-namestring "ccl:") + (if use-cvs cvs-update svn-update))) + :output s)) + (when (and (eq status :exited) + (eql exit-code 0)) + (format t "~&~a" (get-output-stream-string s)) + t)))) + + Index: /branches/event-ide/ccl/lib/describe.lisp =================================================================== --- /branches/event-ide/ccl/lib/describe.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/describe.lisp (revision 8262) @@ -1546,5 +1546,7 @@ *backtrace-internal-functions*)) (break-condition :accessor break-condition - :initarg :break-condition))) + :initarg :break-condition) + (unavailable-value-marker :initform (cons nil nil) + :accessor unavailable-value-marker))) @@ -1561,7 +1563,9 @@ (defmethod compute-frame-info ((f error-frame) n) (let* ((frame (svref (addresses f) n)) - (context (context f))) + (context (context f)) + (marker (unavailable-value-marker f))) + (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame) - (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc) + (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker) (list (ccl::arglist-from-map lfun) args locals))))) Index: /branches/event-ide/ccl/lib/foreign-types.lisp =================================================================== --- /branches/event-ide/ccl/lib/foreign-types.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/foreign-types.lisp (revision 8262) @@ -1700,4 +1700,5 @@ (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)) (canonicalize-foreign-type-ordinal '(:* (:struct :hostent))) + (canonicalize-foreign-type-ordinal '(:array :int 2)) ))) Index: /branches/event-ide/ccl/lib/hash.lisp =================================================================== --- /branches/event-ide/ccl/lib/hash.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/hash.lisp (revision 8262) @@ -159,5 +159,7 @@ ':test (hash-table-test table) (hash-table-count table) - (hash-table-size table)))) + (hash-table-size table)) + (when (readonly-hash-table-p table) + (format stream " (Readonly)")))) @@ -208,61 +210,21 @@ -(defun start-hash-table-iterator (hash state) - (let (vector) - (unless (hash-table-p hash) - (setf (hti.hash-table state) nil) ; for finish-hash-table-iterator - (report-bad-arg hash 'hash-table)) - - (without-interrupts - (setf (hti.hash-table state) hash) - (lock-hash-table hash) - (%lock-gc-lock) - (setq vector (nhash.vector hash)) - (setf (hti.vector state) vector) - (setf (hti.index state) (nhash.vector-size vector)) - (setf (hti.prev-iterator state) (nhash.iterator hash) - (nhash.iterator hash) state) - (when (%needs-rehashing-p hash) - (%rehash hash))))) - -;;; this is as fast as the lappy version - -(defun do-hash-table-iteration (state) - (let ((vector (hti.vector state)) - (index (hti.index state)) - key value) - (declare (optimize (speed 3) (safety 0))) - (if (setf (hti.index state) - (if index - (loop - (if (eq index 0)(return (setq index nil))) - (locally (declare (fixnum index)) - (setq index (- index 1)) - (let* ((vector-index (index->vector-index index))) - (declare (fixnum vector-index)) - (setq key (%svref vector vector-index)) - (unless (or (eq key (%unbound-marker)) - (eq key (%slot-unbound-marker))) - (setq value (%svref vector (the fixnum (1+ vector-index)))) - (return index))))))) - (let* ((hash (hti.hash-table state))) - (setf (nhash.vector.cache-idx (setq vector (nhash.vector hash))) index - (nhash.vector.cache-key vector) key - (nhash.vector.cache-value vector) value) - (values t key value))))) - -(defun finish-hash-table-iterator (state) - (without-interrupts - (let ((hash (hti.hash-table state))) - (when hash - (setf (hti.hash-table state) nil) - (unlock-hash-table hash) - (%unlock-gc-lock) - (when (eq state (nhash.iterator hash)) - (setf (nhash.iterator hash) (hti.prev-iterator state))) - (setf - (hti.index state) nil - (hti.vector state) nil - (hti.lock state) nil))))) + +(defun next-hash-table-iteration-1 (state) + (do* ((index (nhti.index state) (1+ index)) + (keys (nhti.keys state)) + (values (nhti.values state)) + (nkeys (nhti.nkeys state))) + ((>= index nkeys) + (setf (nhti.index state) nkeys) + (values nil nil nil)) + (declare (fixnum index nkeys) + (simple-vector keys)) + (let* ((key (svref keys index)) + (value (svref values index))) + (setf (nhti.index state) (1+ index)) + (return (values t key value))))) + + (defun maphash (function hash-table) Index: /branches/event-ide/ccl/lib/late-clos.lisp =================================================================== --- /branches/event-ide/ccl/lib/late-clos.lisp (revision 8262) +++ /branches/event-ide/ccl/lib/late-clos.lisp (revision 8262) @@ -0,0 +1,72 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2007, Clozure Associates and contributors. +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Maybe compile specialized discriminating code (dcode) for generic +;;; functions, if it seems likely that that might perform better than +;;; the general generic-function-dispatch mechanism. + +(defparameter *compile-dcode-functions* nil) + +;;; If the GF accepts a fixed number of arguments, return its +;;; lambda list. +(defun gf-fixed-arg-lambda-list (gf) + (let* ((lambda-list (generic-function-lambda-list gf))) + (dolist (arg lambda-list lambda-list) + (when (member arg lambda-list-keywords) + (return nil))))) + +(defun generate-conformance-test (arg-name specializer) + (cond ((typep specializer 'eql-specializer) + `(eql ,arg-name ',(eql-specializer-object specializer))) + ((eq specializer *t-class*)) + ((typep specializer 'standard-class) + (let* ((wrapper (gensym))) + `(let* ((,wrapper (if (= (the fixnum (typecode ,arg-name)) + target::subtag-instance) + (instance.class-wrapper ,arg-name)))) + (and ,wrapper + (memq ,specializer (or (%wrapper-cpl ,wrapper) + (%inited-class-cpl + (%wrapper-class ,wrapper)))))))) + (t `(typep ,arg-name ',(class-name specializer))))) + +(defun generate-conformance-clause (args method) + `((and ,@(mapcar #'generate-conformance-test args (method-specializers method))) + (funcall ,(method-function method) ,@args))) + +;;; Generate code to call the single fixed-arg primary method +;;; defined on GF if all args are conformant, or to call +;;; NO-APPLICABLE-METHOD otherwise. +;;; Note that we can often do better than this for accessor +;;; methods (especially reader methods) as a very late (delivery-time) +;;; optimization. +(defun dcode-for-fixed-arg-singleton-gf (gf) + (when *compile-dcode-functions* + (let* ((methods (generic-function-methods gf)) + (method (car methods)) + (args (gf-fixed-arg-lambda-list gf))) + (when (and method + args + (null (cdr methods)) + (null (method-qualifiers method)) + (dolist (spec (method-specializers method)) + (unless (eq spec *t-class*) (return t)))) + (compile nil + `(lambda ,args + (cond ,(generate-conformance-clause args method) + (t (no-applicable-method ,gf ,@args))))))))) + +(register-non-dt-dcode-function #'dcode-for-fixed-arg-singleton-gf) Index: /branches/event-ide/ccl/lib/macros.lisp =================================================================== --- /branches/event-ide/ccl/lib/macros.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/macros.lisp (revision 8262) @@ -1493,4 +1493,28 @@ ,@body))) +(defmacro with-self-bound-io-control-vars (&body body) + `(let ( + (*print-array* *print-array*) + (*print-base* *print-base*) + (*print-case* *print-case*) + (*print-circle* *print-circle*) + (*print-escape* *print-escape*) + (*print-gensym* *print-gensym*) + (*print-length* *print-length*) + (*print-level* *print-level*) + (*print-lines* *print-lines*) + (*print-miser-width* *print-miser-width*) + (*print-pprint-dispatch* *print-pprint-dispatch*) + (*print-pretty* *print-pretty*) + (*print-radix* *print-radix*) + (*print-readably* *print-readably*) + (*print-right-margin* *print-right-margin*) + (*read-base* *read-base*) + (*read-default-float-format* *read-default-float-format*) + (*read-eval* *read-eval*) + (*read-suppress* *read-suppress*) + (*readtable* *readtable*)) + ,@body)) + (defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms) "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally @@ -1581,4 +1605,21 @@ ,@body)))))) +(defmacro with-utf-8-cstr ((sym str) &body body) + (let* ((data (gensym)) + (offset (gensym)) + (string (gensym)) + (len (gensym)) + (noctets (gensym)) + (end (gensym))) + `(let* ((,string ,str) + (,len (length ,string))) + (multiple-value-bind (,data ,offset) (array-data-and-offset ,string) + (let* ((,end (+ ,offset ,len)) + (,noctets (utf-8-octets-in-string ,data ,offset ,end))) + (%stack-block ((,sym (1+ ,noctets))) + (utf-8-memory-encode ,data ,sym 0 ,offset ,end) + (setf (%get-unsigned-byte ,sym ,noctets) 0) + ,@body)))))) + @@ -1592,4 +1633,7 @@ (defmacro with-cstrs (speclist &body body) (with-specs-aux 'with-cstr speclist body)) + +(defmacro with-utf-8-cstrs (speclist &body body) + (with-specs-aux 'with-utf-8-cstr speclist body)) (defmacro with-encoded-cstr ((encoding-name (sym string &optional start end)) @@ -2291,4 +2335,14 @@ (free-resource ,resource-var ,var)))))) +;;; Bind per-thread specials which help with lock accounting. +(defmacro with-lock-context (&body body) + #+lock-accounting + `(let* ((*locks-held* *locks-held*) + (*locks-pending* *locks-pending*) + (*lock-conses* *lock-conses*)) + ,@body) + #-lock-accounting + `(progn ,@body)) + (defmacro with-lock-grabbed ((lock &optional (whostate "Lock")) @@ -2297,5 +2351,15 @@ the lock held." (declare (ignore whostate)) - `(with-recursive-lock (,lock) ,@body)) + (let* ((locked (gensym)) + (l (gensym))) + ` (with-lock-context + (let ((,locked (make-lock-acquisition)) + (,l ,lock)) + (declare (dynamic-extent ,locked)) + (unwind-protect + (progn + (%lock-recursive-lock-object ,l ,locked ) + ,@body) + (when (lock-acquisition.status ,locked) (%unlock-recursive-lock-object ,l))))))) (defmacro with-lock-grabbed-maybe ((lock &optional @@ -2303,5 +2367,11 @@ &body body) (declare (ignore whostate)) - `(with-recursive-lock-maybe (,lock) ,@body)) + (let* ((l (gensym))) + `(with-lock-context + (let* ((,l ,lock)) + (when (%try-recursive-lock-object ,l) + (unwind-protect + (progn ,@body) + (%unlock-recursive-lock-object ,l))))))) (defmacro with-standard-abort-handling (abort-message &body body) @@ -2548,13 +2618,5 @@ nil)) -(defmacro with-hash-write-lock ((hash) &body body) - `(with-write-lock ((nhash.exclusion-lock ,hash)) - ,@body)) - -;;; To ... er, um, ... expedite implementation, we lock the hash -;;; table exclusively whenever touching it. For now. - -(defmacro with-exclusive-hash-lock ((hash) &body body) - `(with-hash-write-lock (,hash) ,@body)) + (defmacro with-hash-table-iterator ((mname hash-table) &body body &environment env) @@ -2565,16 +2627,19 @@ any objects remain in the hash table. When the first value is non-NIL, the second and third values are the key and the value of the next object." - (let ((state (gensym)) - (htab (gensym))) - (multiple-value-bind (body decls) (parse-body body env) - `(let* ((,htab ,hash-table) - (,state (vector nil nil nil - nil nil))) - (declare (dynamic-extent ,state)) - (unwind-protect - (macrolet ((,mname () `(do-hash-table-iteration ,',state))) - (start-hash-table-iterator ,htab ,state) - (locally ,@decls ,@body)) - (finish-hash-table-iterator ,state)))))) + (let* ((hash (gensym)) + (keys (gensym)) + (values (gensym)) + (count (gensym)) + (state (gensym))) + `(let* ((,hash ,hash-table) + (,count (hash-table-count ,hash)) + (,keys (make-array ,count)) + (,values (make-array ,count)) + (,state (vector ,hash 0 ,keys ,values (enumerate-hash-keys-and-values ,hash ,keys ,values)))) + (declare (dynamic-extent ,keys ,state) + (fixnum ,count)) + (macrolet ((,mname () `(next-hash-table-iteration-1 ,',state))) + ,@body)))) + (eval-when (compile load eval) @@ -2907,5 +2972,12 @@ (setf (,accessor ,dst ,i) (,accessor ,src ,i)))))) - +(defmacro assert-pointer-type (pointer type) + "Assert that the pointer points to an instance of the specified foreign type. +Return the pointer." + (let* ((ptr (gensym))) + `(let* ((,ptr ,pointer)) + (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type)))) + ,ptr))) + @@ -2920,40 +2992,10 @@ (defmacro with-process-whostate ((whostate) &body body) - (let* ((p (gensym)) - (old-whostate (gensym))) - `(let* ((,p *current-process*) - (,old-whostate (process-whostate ,p))) - (unwind-protect - (progn - (setf (%process-whostate ,p) ,whostate) - ,@body) - (setf (%process-whostate ,p) ,old-whostate))))) - -(defmacro %with-recursive-lock-ptr ((lockptr) &body body) - (let* ((locked (gensym))) - `(let ((,locked (make-lock-acquisition))) - (declare (dynamic-extent ,locked)) - (unwind-protect - (progn - (%lock-recursive-lock ,lockptr ,locked ) - ,@body) - (when (lock-acquisition.status ,locked) (%unlock-recursive-lock ,lockptr)))))) - -(defmacro %with-recursive-lock-ptr-maybe ((lockptr) &body body) - `(when (%try-recursive-lock ,lockptr) - (unwind-protect - (progn ,@body) - (%unlock-recursive-lock ,lockptr)))) - - -(defmacro with-recursive-lock ((lock) &body body) - (let* ((p (gensym))) - `(let* ((,p (recursive-lock-ptr ,lock))) - (%with-recursive-lock-ptr (,p) ,@body)))) - -(defmacro with-recursive-lock-maybe ((lock) &body body) - (let* ((p (gensym))) - `(let* ((,p (recursive-lock-ptr ,lock))) - (%with-recursive-lock-ptr-maybe (,p) ,@body)))) + `(let* ((*whostate* ,whostate)) + ,@body)) + + + + (defmacro with-read-lock ((lock) &body body) @@ -2961,10 +3003,11 @@ its body with the lock held." (let* ((p (gensym))) - `(let* ((,p ,lock)) - (unwind-protect - (progn - (read-lock-rwlock ,p) - ,@body) - (unlock-rwlock ,p))))) + `(with-lock-context + (let* ((,p ,lock)) + (unwind-protect + (progn + (read-lock-rwlock ,p) + ,@body) + (unlock-rwlock ,p)))))) @@ -2973,10 +3016,11 @@ its body with the lock held." (let* ((p (gensym))) - `(let* ((,p ,lock)) + `(with-lock-context + (let* ((,p ,lock)) (unwind-protect (progn (write-lock-rwlock ,p) ,@body) - (unlock-rwlock ,p))))) + (unlock-rwlock ,p)))))) @@ -2988,4 +3032,22 @@ ,@body) (%unlock-gc-lock))) + +(defmacro with-deferred-gc (&body body) + "Execute BODY without responding to the signal used to suspend +threads for GC. BODY must be very careful not to do anything which +could cause an exception (note that attempting to allocate lisp memory +may cause an exception.)" + `(let* ((*interrupt-level* -2)) + ,@body)) + +(defmacro allowing-deferred-gc (&body body) + "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC." + `(let* ((*interrupt-level* -1)) + (%check-deferred-gc) + ,@body)) + +(defmacro defer-gc () + `(setq *interrupt-level* -2)) + (defmacro with-pointer-to-ivector ((ptr ivector) &body body) @@ -3442,8 +3504,11 @@ (let ((,res (progn ,@body))) (if (eql ,res (- ,eagain)) - (,(ecase direction - (:input 'process-input-wait) - (:output 'process-output-wait)) - ,fd) + (progn + (setq ,res + (,(ecase direction + (:input 'process-input-would-block) + (:output 'process-output-would-block)) + ,fd)) + (unless (eq ,res t) (return ,res))) (return ,res)))))) Index: /branches/event-ide/ccl/lib/misc.lisp =================================================================== --- /branches/event-ide/ccl/lib/misc.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/misc.lisp (revision 8262) @@ -373,8 +373,8 @@ :FORM the form that was executed :RESULTS a list of all values returned by the execution of FORM - :ELAPSED-TIME total elapsed (real) time, in milliseconds - :USER-TIME elapsed user time, in milliseconds - :SYSTEM-TIME elapsed system time, in milliseconds - :GC-TIME total real time spent in the GC, in milliseconds + :ELAPSED-TIME total elapsed (real) time, in internal-time-units-per-second + :USER-TIME elapsed user time, in internal-time-units-per-second + :SYSTEM-TIME elapsed system time, in internal-time-units-per-second + :GC-TIME total real time spent in the GC, in internal-time-units-per-second :BYTES-ALLOCATED total bytes allocated :MINOR-PAGE-FAULTS minor page faults @@ -388,13 +388,21 @@ swaps) (let* ((s *trace-output*) + (units + (ecase internal-time-units-per-second + (1000000 "microseconds") + (1000 "milliseconds"))) + (width + (ecase internal-time-units-per-second + (1000000 6) + (100 3))) (cpu-count (cpu-count))) - (format s "~&~S took ~:D milliseconds (~,3F seconds) to run ~%~20twith ~D available CPU core~P." - form elapsed-time (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count) - (format s "~&During that period, ~:D milliseconds (~,3F seconds) were spent in user mode" user-time (/ user-time internal-time-units-per-second)) - (format s "~& ~:D milliseconds (~,3F seconds) were spent in system mode" system-time (/ system-time internal-time-units-per-second)) + (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P." + form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count) + (format s "~&During that period, ~:D ~a (~,vF seconds) were spent in user mode" user-time units width (/ user-time internal-time-units-per-second)) + (format s "~& ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second)) (unless (eql gc-time 0) (format s - "~%~:D milliseconds (~,3F seconds) was spent in GC." - gc-time (/ gc-time internal-time-units-per-second))) + "~%~:D ~a (~,vF seconds) was spent in GC." + gc-time units width (/ gc-time internal-time-units-per-second))) (unless (eql 0 bytes-allocated) (format s "~% ~:D bytes of memory allocated." bytes-allocated)) @@ -435,5 +443,7 @@ (pref stop :rusage.ru_utime) (pref start :rusage.ru_utime)) - (timeval->milliseconds timediff))) + (ecase internal-time-units-per-second + (1000000 (timeval->microseconds timediff)) + (1000 (timeval->milliseconds timediff))))) (elapsed-system-time (progn @@ -441,5 +451,7 @@ (pref stop :rusage.ru_stime) (pref start :rusage.ru_stime)) - (timeval->milliseconds timediff))) + (ecase internal-time-units-per-second + (1000000 (timeval->microseconds timediff)) + (1000 (timeval->milliseconds timediff))))) (elapsed-minor (- (pref stop :rusage.ru_minflt) (pref start :rusage.ru_minflt))) @@ -712,2 +724,119 @@ (when (and line (parse-integer line :junk-allowed t) ) (return-from local-svn-revision line))))))))) + + +;;; Scan the heap, collecting infomation on the primitive object types +;;; found. Report that information. + +(defun heap-utilization (&key (stream *debug-io*) + (gc-first t)) + (let* ((nconses 0) + (nvectors (make-array 256)) + (vector-sizes (make-array 256)) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*)))) + (declare (type (simple-vector 256) nvectors vector-sizes) + (dynamic-extent nvectors vector-sizes)) + (when gc-first (gc)) + (%map-areas (lambda (thing) + (if (consp thing) + (incf nconses) + (let* ((typecode (typecode thing))) + (incf (aref nvectors typecode)) + (incf (aref vector-sizes typecode) + (funcall array-size-function typecode (uvsize thing))))))) + (report-heap-utilization stream nconses nvectors vector-sizes) + (values))) + +(defvar *heap-utilization-vector-type-names* + (let* ((a (make-array 256))) + #+x8664-target + (dotimes (i 256) + (let* ((fulltag (logand i x8664::fulltagmask)) + (names-vector + (cond ((= fulltag x8664::fulltag-nodeheader-0) + *nodeheader-0-types*) + ((= fulltag x8664::fulltag-nodeheader-1) + *nodeheader-1-types*) + ((= fulltag x8664::fulltag-immheader-0) + *immheader-0-types*) + ((= fulltag x8664::fulltag-immheader-1) + *immheader-1-types*) + ((= fulltag x8664::fulltag-immheader-2) + *immheader-2-types*))) + (name (if names-vector + (aref names-vector (ash i -4))))) + ;; Special-case a few things ... + (if (eq name 'symbol-vector) + (setq name 'symbol) + (if (eq name 'function-vector) + (setq name 'function))) + (setf (aref a i) name))) + #+ppc64-target + (dotimes (i 256) + (let* ((lowtag (logand i ppc64::lowtagmask))) + (setf (%svref a i) + (cond ((= lowtag ppc64::lowtag-immheader) + (%svref *immheader-types* (ash i -2))) + ((= lowtag ppc64::lowtag-nodeheader) + (%svref *nodeheader-types* (ash i -2))))))) + #+ppc32-target + (dotimes (i 256) + (let* ((fulltag (logand i ppc32::fulltagmask))) + (setf (%svref a i) + (cond ((= fulltag ppc32::fulltag-immheader) + (%svref *immheader-types* (ash i -3))) + ((= fulltag ppc32::fulltag-nodeheader) + (%svref *nodeheader-types* (ash i -3))))))) + a)) + + + +(defun report-heap-utilization (out nconses nvectors vector-sizes) + (format out "~&Object type~42tCount~50tTotal Size in Bytes") + (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size)) + (dotimes (i (length nvectors)) + (let* ((count (aref nvectors i)) + (sizes (aref vector-sizes i))) + (unless (zerop count) + (format out "~&~a~36t~12d~48t~16d" (aref *heap-utilization-vector-type-names* i) count sizes))))) + +;; The number of words to allocate for static conses when the user requests +;; one and we don't have any left over +(defparameter *static-cons-chunk* 1048576) + +(defun initialize-static-cons () + "Activates collection of garbage conses in the static-conses + list and allocates initial static conses." + ; There might be a race here when multiple threads call this + ; function. However, the discarded static conses will become + ; garbage and be added right back to the list. No harm here + ; except for additional garbage collections. + (%set-kernel-global 'static-conses nil) + (allocate-static-conses)) + +(defun allocate-static-conses () + "Allocates some memory, freezes it and lets it become garbage. + This will add the memory to the list of free static conses." + (let ((l (make-array *static-cons-chunk*))) + (declare (ignore l)) + (freeze)) + (gc)) + +(defun static-cons (car-value cdr-value) + "Allocates a cons cell that doesn't move on garbage collection, + and thus doesn't trigger re-hashing when used as a key in a hash + table. Usage is equivalent to regular CONS." + (when (eq (%get-kernel-global 'static-conses) 0) + (initialize-static-cons)) + (let ((cell (%atomic-pop-static-cons))) + (if cell + (progn + (setf (car cell) car-value) + (setf (cdr cell) cdr-value) + cell) + (progn + (allocate-static-conses) + (static-cons car-value cdr-value))))) + + Index: /branches/event-ide/ccl/lib/nfcomp.lisp =================================================================== --- /branches/event-ide/ccl/lib/nfcomp.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/nfcomp.lisp (revision 8262) @@ -832,7 +832,7 @@ (push (cons opcode args) *fcomp-output-list*)) -;Compile a lambda expression for the sole purpose of putting it in a fasl -;file. The result will not be funcalled. This really shouldn't bother -;making an lfun, but it's simpler this way... +;;; Compile a lambda expression for the sole purpose of putting it in a fasl +;;; file. The result will not be funcalled. This really shouldn't bother +;;; making an lfun, but it's simpler this way... (defun fcomp-named-function (def name env) (let* ((env (new-lexical-environment env))) @@ -893,5 +893,5 @@ ;These should be constants, but it's too much trouble when need to change 'em. (defparameter FASL-FILE-ID #xFF00) ;Overall file format, shouldn't change much -(defparameter FASL-VERSION #xFF4e) ;Fasl block format. +(defparameter FASL-VERSION #xFF51) ;Fasl block format. (defvar *fasdump-hash*) @@ -1316,5 +1316,5 @@ (let* ((nb (ash (+ n 7) -3))) (fasl-out-ivect v 0 nb)) - (break "need to byte-swap ~a" v)))) + (compiler-bug "need to byte-swap ~a" v)))) (defun fasl-dump-8-bit-ivector (v op) @@ -1359,5 +1359,5 @@ (let* ((nb (ash n 3))) (fasl-out-ivect v 0 nb)) - (break "need to byte-swap ~a" v)))) + (compiler-bug "need to byte-swap ~a" v)))) (defun fasl-dump-double-float-vector (v) @@ -1369,5 +1369,5 @@ (fasl-out-ivect v (- target::misc-dfloat-offset target::misc-data-offset) nb)) - (break "need to byte-swap ~a" v)))) + (compiler-bug "need to byte-swap ~a" v)))) ;;; This is used to dump functions and "xfunctions". @@ -1379,5 +1379,5 @@ (if (and (not (eq *fasl-backend* *host-backend*)) (typep f 'function)) - (break "Dumping a native function constant ~s during cross-compilation." f)) + (compiler-bug "Dumping a native function constant ~s during cross-compilation." f)) (if (and (= (typecode f) target::subtag-xfunction) (= (typecode (uvref f 0)) target::subtag-u8-vector)) @@ -1393,5 +1393,5 @@ (if (and (not (eq *fasl-backend* *host-backend*)) (typep f 'function)) - (break "Dumping a native function constant ~s during cross-compilation." f)) + (compiler-bug "Dumping a native function constant ~s during cross-compilation." f)) (if (and (= (typecode f) target::subtag-xfunction) (= (typecode (uvref f 0)) target::subtag-u8-vector)) @@ -1442,5 +1442,5 @@ (if (and (not (eq *fasl-backend* *host-backend*)) (typep c 'code-vector)) - (break "Dumping a native code-vector constant ~s during cross-compilation." c)) + (compiler-bug "Dumping a native code-vector constant ~s during cross-compilation." c)) (let* ((n (uvsize c))) (fasl-out-opcode $fasl-code-vector c) Index: /branches/event-ide/ccl/lib/numbers.lisp =================================================================== --- /branches/event-ide/ccl/lib/numbers.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/numbers.lisp (revision 8262) @@ -350,10 +350,18 @@ (defparameter a-short-float 1.0s0) - +#+32-bit-target (defmethod print-object ((rs random-state) stream) (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! 'ccl::initialize-random-state - (%svref rs 1) - (%svref rs 2))) + (random.seed-1 rs) + (random.seed-2 rs))) + +#+64-bit-target +(defmethod print-object ((rs random-state) stream) + (let* ((s1 (random.seed-1 rs))) + (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! + 'ccl::initialize-random-state + (ldb (byte 16 16) s1) + (ldb (byte 16 0) s1)))) Index: /branches/event-ide/ccl/lib/pathnames.lisp =================================================================== --- /branches/event-ide/ccl/lib/pathnames.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/pathnames.lisp (revision 8262) @@ -185,9 +185,5 @@ -(defun lock-file (path) - (break "lock-file ? ~s" path)) - -(defun unlock-file (path) - (break "unlock-file ? ~s" path)) + (defun create-directory (path &key (mode #o777)) Index: /branches/event-ide/ccl/lib/ppc-backtrace.lisp =================================================================== --- /branches/event-ide/ccl/lib/ppc-backtrace.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/ppc-backtrace.lisp (revision 8262) @@ -250,4 +250,28 @@ (get-register-value nil last-catch index))) +(defun %set-register-argument-value (context cfp regval new) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp + (child-frame frame context)) + (first t)) + ((null frame)) + (if (fake-stack-frame-p frame) + (return-from %set-register-argument-value + (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new)) + (if first + (setq first nil) + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + (return-from + %set-register-argument-value + (raw-frame-set frame context where new))))))))) + (set-register-value new nil last-catch index))) + (defun %raw-frame-ref (cfp context idx bad) (declare (fixnum idx)) @@ -273,4 +297,27 @@ bad)))) +(defun %raw-frame-set (cfp context idx new) + (declare (fixnum idx)) + (multiple-value-bind (frame base) + (vsp-limits cfp context) + (let* ((raw-size (- base frame))) + (declare (fixnum frame base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (setf (oldest-binding-frame-value context addr) new) + (setf (%fixnum-ref addr) new)))) + t))))) + ;;; Used for printing only. (defun index->address (p) @@ -303,2 +350,531 @@ (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell)) value))) + +;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's +;;; pretty PPC-specific + +;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there. +(defun set-lisp-data (vstack-index data) + (let* ((old (%access-lisp-data vstack-index))) + (if (closed-over-value-p old) + (set-closed-over-value old data) + (%store-lisp-data vstack-index data)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;extensions to let user access and modify values + + + + + +;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace" + + + + + + +(defparameter *saved-register-count+1* + (1+ *saved-register-count*)) + + + +(defparameter *saved-register-numbers* + #+x8664-target #(wrong) + #+ppc-target #(31 30 29 28 27 26 25 24)) + +;;; Don't do unbound checks in compiled code +(declaim (type t *saved-register-count* *saved-register-count+1* + *saved-register-names* *saved-register-numbers*)) + +(defmacro %cons-saved-register-vector () + `(make-array (the fixnum *saved-register-count+1*) :initial-element nil)) + +(defun copy-srv (from-srv &optional to-srv) + (if to-srv + (if (eq from-srv to-srv) + to-srv + (dotimes (i (uvsize from-srv) to-srv) + (setf (uvref to-srv i) (uvref from-srv i)))) + (copy-uvector from-srv))) + +(defmacro srv.unresolved (saved-register-vector) + `(svref ,saved-register-vector 0)) + +(defmacro srv.register-n (saved-register-vector n) + `(svref ,saved-register-vector (1+ ,n))) + +;;; This isn't quite right - has to look at all functions on stack, +;;; not just those that saved VSPs. + + +(defun frame-restartable-p (target &optional context) + (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context) + (when frame + (loop + (when (null frame) + (return-from frame-restartable-p nil)) + (when (eq frame target) (return)) + (multiple-value-setq (frame last-catch srv) + (ccl::parent-frame-saved-vars context frame last-catch srv srv))) + (when (and srv (eql 0 (srv.unresolved srv))) + (setf (srv.unresolved srv) last-catch) + srv)))) + + +;;; get the saved register addresses for this frame +;;; still need to worry about this unresolved business +;;; could share some code with parent-frame-saved-vars +(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector))) + (let ((unresolved 0)) + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (if lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (when mask + (if (not where) + (setq unresolved (%ilogior unresolved mask)) + (let ((vsp (- (frame-vsp frame) where (1- (logcount mask)))) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (when (%ilogbitp (decf j) mask) + (setf (srv.register-n srv-out i) vsp + vsp (1+ vsp) + unresolved (%ilogand unresolved (%ilognot (%ilsl j 1)))))))))) + (setq unresolved (1- (ash 1 *saved-register-count*))))) + (setf (srv.unresolved srv-out) unresolved) + srv-out)) + +(defun parent-frame-saved-vars + (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector))) + (copy-srv srv srv-out) + (let* ((parent (and frame (parent-frame frame context))) + (grand-parent (and parent (parent-frame parent context)))) + (when grand-parent + (loop (let ((next-catch (and last-catch (next-catch last-catch)))) + ;(declare (ignore next-catch)) + (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context)) + (progn + (setf last-catch next-catch + (srv.unresolved srv-out) 0) + (dotimes (i *saved-register-count*) + (setf (srv.register-n srv i) nil))) + (return)))) + (lookup-registers parent context grand-parent srv-out) + (values parent last-catch srv-out)))) + +(defun lookup-registers (parent context grand-parent srv-out) + (unless (or (eql (frame-vsp grand-parent) 0) + (let ((gg-parent (parent-frame grand-parent context))) + (eql (frame-vsp gg-parent) 0))) + (multiple-value-bind (lfun pc) (cfp-lfun parent) + (when lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (when mask + (locally (declare (fixnum mask)) + (if (not where) + (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask)) + (let* ((grand-parent-vsp (frame-vsp grand-parent))) + + (let ((vsp (- grand-parent-vsp where 1)) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (when (%ilogbitp (decf j) mask) + (setf (srv.register-n srv-out i) vsp + vsp (1- vsp) + (srv.unresolved srv-out) + (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1)))))))))))))))) + +;;; initialization for looping on parent-frame-saved-vars +(defun last-catch-since-saved-vars (frame context) + (let* ((parent (parent-frame frame context)) + (last-catch (and parent (last-catch-since parent context)))) + (when last-catch + (let ((frame (catch-frame-sp last-catch)) + (srv (%cons-saved-register-vector))) + (setf (srv.unresolved srv) 0) + (let* ((parent (parent-frame frame context)) + (child (and parent (child-frame parent context)))) + (when child + (lookup-registers child context parent srv)) + (values child last-catch srv)))))) + +;;; Returns 2 values: +;;; mask srv +;;; The mask says which registers are used at PC in LFUN. srv is a +;;; saved-register-vector whose register contents are the register +;;; values registers whose bits are not set in MASK or set in +;;; UNRESOLVED will be returned as NIL. + +(defun saved-register-values + (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector))) + (declare (ignore child)) + (cond ((null srv-out) (setq srv-out (copy-uvector srv))) + ((eq srv-out srv)) + (t (dotimes (i (the fixnum (uvsize srv))) + (setf (uvref srv-out i) (uvref srv i))))) + (let ((mask (or (registers-used-by lfun pc) 0)) + (unresolved (srv.unresolved srv)) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (setf (srv.register-n srv-out i) + (and (%ilogbitp (setq j (%i- j 1)) mask) + (not (%ilogbitp j unresolved)) + (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j))))) + (setf (srv.unresolved srv-out) mask) + (values mask srv-out))) + +; Set the nth saved register to value. +(defun set-saved-register (value n lfun pc child last-catch srv) + (declare (ignore lfun pc child) (dynamic-extent saved-register-values)) + (let ((j (- target::node-size n)) + (unresolved (srv.unresolved srv)) + (addr (srv.register-n srv n))) + (when (logbitp j unresolved) + (error "Can't set register ~S to ~S" n value)) + (set-register-value value addr last-catch j)) + value) + + + + + +(defun return-from-nth-frame (n &rest values) + (apply-in-nth-frame n #'values values)) + +(defun apply-in-nth-frame (n fn arglist) + (let* ((bt-info (car *backtrace-contexts*))) + (and bt-info + (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info))) + (and frame (apply-in-frame frame fn arglist))))) + (format t "Can't return to frame ~d ." n)) + +;;; This method is shadowed by one for the backtrace window. +(defmethod nth-frame (w target n context) + (declare (ignore w)) + (and target (dotimes (i n target) + (declare (fixnum i)) + (unless (setq target (parent-frame target context)) (return nil))))) + +; If this returns at all, it's because the frame wasn't restartable. +(defun apply-in-frame (frame fn arglist &optional context) + (let* ((srv (frame-restartable-p frame context)) + (target-sp (and srv (srv.unresolved srv)))) + (if target-sp + (apply-in-frame-internal context frame fn arglist srv)))) + +(defun apply-in-frame-internal (context frame fn arglist srv) + (let* ((tcr (if context (bt.tcr context) (%current-tcr)))) + (if (eq tcr (%current-tcr)) + (%apply-in-frame frame fn arglist srv) + (let ((process (tcr->process tcr))) + (if process + (process-interrupt + process + #'%apply-in-frame + frame fn arglist srv) + (error "Can't find active process for ~s" tcr)))))) + + + + +;;; (srv.unresolved srv) is the last catch frame, left there by +;;; frame-restartable-p The registers in srv are locations of +;;; variables saved between frame and that catch frame. +(defun %apply-in-frame (frame fn arglist srv) + (declare (fixnum frame)) + (let* ((catch (srv.unresolved srv)) + (tsp-count 0) + (tcr (%current-tcr)) + (parent (parent-frame frame tcr)) + (vsp (frame-vsp parent)) + (catch-top (%catch-top tcr)) + (db-link (%svref catch target::catch-frame.db-link-cell)) + (catch-count 0)) + (declare (fixnum parent vsp db-link catch-count)) + ;; Figure out how many catch frames to throw through + (loop + (unless catch-top + (error "Didn't find catch frame")) + (incf catch-count) + (when (eq catch-top catch) + (return)) + (setq catch-top (next-catch catch-top))) + ;; Figure out where the db-link should be + (loop + (when (or (eql db-link 0) (>= db-link vsp)) + (return)) + (setq db-link (%fixnum-ref db-link))) + ;; Figure out how many TSP frames to pop after throwing. + (let ((sp (catch-frame-sp catch))) + (loop + (multiple-value-bind (f pc) (cfp-lfun sp) + (when f (incf tsp-count (active-tsp-count f pc)))) + (setq sp (parent-frame sp tcr)) + (when (eql sp parent) (return)) + (unless sp (error "Didn't find frame: ~s" frame)))) + #+debug + (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)" + catch-count srv tsp-count db-link parent fn arglist) + (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist))) + + + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Code to determine how many tsp frames to pop. +;;; This is done by parsing the code. +;;; active-tsp-count is the entry point below. +;;; + +(defstruct (branch-tree (:print-function print-branch-tree)) + first-instruction + last-instruction + branch-target ; a branch-tree or nil + fall-through) ; a branch-tree or nil + +(defun print-branch-tree (tree stream print-level) + (declare (ignore print-level)) + (print-unreadable-object (tree stream :type t :identity t) + (format stream "~s-~s" + (branch-tree-first-pc tree) + (branch-tree-last-pc tree)))) + +(defun branch-tree-first-pc (branch-tree) + (let ((first (branch-tree-first-instruction branch-tree))) + (and first (instruction-element-address first)))) + +(defun branch-tree-last-pc (branch-tree) + (let ((last (branch-tree-last-instruction branch-tree))) + (if last + (instruction-element-address last) + (branch-tree-first-pc branch-tree)))) + +(defun branch-tree-contains-pc-p (branch-tree pc) + (<= (branch-tree-first-pc branch-tree) + pc + (branch-tree-last-pc branch-tree))) + +(defvar *branch-tree-hash* + (make-hash-table :test 'eq :weak :value)) + +(defun get-branch-tree (function) + (or (gethash function *branch-tree-hash*) + (let* ((dll (function-to-dll-header function)) + (tree (dll-to-branch-tree dll))) + (setf (gethash function *branch-tree-hash*) tree)))) + +; Return the number of TSP frames that will be active after throwing out +; of all the active catch frames in function at pc. +; PC is a byte address, a multiple of 4. +(defun active-tsp-count (function pc) + (setq function + (require-type + (if (symbolp function) + (symbol-function function) + function) + 'compiled-function)) + (let* ((tree (get-branch-tree function)) + (visited nil)) + (labels ((find-pc (branch path) + (unless (memq branch visited) + (push branch path) + (if (branch-tree-contains-pc-p branch pc) + path + (let ((target (branch-tree-branch-target branch)) + (fall-through (branch-tree-fall-through branch))) + (push branch visited) + (if fall-through + (or (and target (find-pc target path)) + (find-pc fall-through path)) + (and target (find-pc target path)))))))) + (let* ((path (nreverse (find-pc tree nil))) + (last-tree (car (last path))) + (catch-count 0) + (tsp-count 0)) + (unless path + (error "Can't find path to pc: ~s in ~s" pc function)) + (dolist (tree path) + (let ((next (branch-tree-first-instruction tree)) + (last (branch-tree-last-instruction tree))) + (loop + (when (and (eq tree last-tree) + (eql pc (instruction-element-address next))) + ; If the instruction before the current one is an ff-call, + ; then callback pushed a TSP frame. + #| ; Not any more + (when (ff-call-instruction-p (dll-node-pred next)) + (incf tsp-count)) + |# + (return)) + (multiple-value-bind (type target fall-through count) (categorize-instruction next) + (declare (ignore target fall-through)) + (case type + (:tsp-push + (when (eql catch-count 0) + (incf tsp-count count))) + (:tsp-pop + (when (eql catch-count 0) + (decf tsp-count count))) + ((:catch :unwind-protect) + (incf catch-count)) + (:throw + (decf catch-count count)))) + (when (eq next last) + (return)) + (setq next (dll-node-succ next))))) + tsp-count)))) + + +(defun dll-to-branch-tree (dll) + (let* ((hash (make-hash-table :test 'eql)) ; start-pc -> branch-tree + (res (collect-branch-tree (dll-header-first dll) dll hash)) + (did-something nil)) + (loop + (setq did-something nil) + (let ((mapper #'(lambda (key value) + (declare (ignore key)) + (flet ((maybe-collect (pc) + (when (integerp pc) + (let ((target-tree (gethash pc hash))) + (if target-tree + target-tree + (progn + (collect-branch-tree (dll-pc->instr dll pc) dll hash) + (setq did-something t) + nil)))))) + (declare (dynamic-extent #'maybe-collect)) + (let ((target-tree (maybe-collect (branch-tree-branch-target value)))) + (when target-tree (setf (branch-tree-branch-target value) target-tree))) + (let ((target-tree (maybe-collect (branch-tree-fall-through value)))) + (when target-tree (setf (branch-tree-fall-through value) target-tree))))))) + (declare (dynamic-extent mapper)) + (maphash mapper hash)) + (unless did-something (return))) + ; To be totally correct, we should fix up the trees containing + ; the BLR instruction for unwind-protect cleanups, but none + ; of the users of this code yet care that it appears that the code + ; stops there. + res)) + +(defun collect-branch-tree (instr dll hash) + (unless (eq instr dll) + (let ((tree (make-branch-tree :first-instruction instr)) + (pred nil) + (next instr)) + (setf (gethash (instruction-element-address instr) hash) + tree) + (loop + (when (eq next dll) + (setf (branch-tree-last-instruction tree) pred) + (return)) + (multiple-value-bind (type target fall-through) (categorize-instruction next) + (case type + (:label + (when pred + (setf (branch-tree-last-instruction tree) pred + (branch-tree-fall-through tree) (instruction-element-address next)) + (return))) + ((:branch :catch :unwind-protect) + (setf (branch-tree-last-instruction tree) next + (branch-tree-branch-target tree) target + (branch-tree-fall-through tree) fall-through) + (return)))) + (setq pred next + next (dll-node-succ next))) + tree))) + +;;; Returns 4 values: +;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop +;;; 2) branch target (or catch or unwind-protect cleanup) +;;; 3) branch-fallthrough (or catch or unwind-protect body) +;;; 4) Count for throw, tsp-push, tsp-pop +(defun categorize-instruction (instr) + (etypecase instr + (lap-label :label) + (lap-instruction + (let* ((opcode (lap-instruction-opcode instr)) + (opcode-p (typep opcode 'opcode)) + (name (if opcode-p (opcode-name opcode) opcode)) + (pc (lap-instruction-address instr)) + (operands (lap-instruction-parsed-operands instr))) + (cond ((equalp name "bla") + (let ((subprim (car operands))) + (case subprim + (.SPmkunwind + (values :unwind-protect (+ pc 4) (+ pc 8))) + ((.SPmkcatch1v .SPmkcatchmv) + (values :catch (+ pc 4) (+ pc 8))) + (.SPthrow + (values :branch nil nil)) + ((.SPnthrowvalues .SPnthrow1value) + (let* ((prev-instr (require-type (lap-instruction-pred instr) + 'lap-instruction)) + (prev-name (opcode-name (lap-instruction-opcode prev-instr))) + (prev-operands (lap-instruction-parsed-operands prev-instr))) + ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I + ; can't imagine we'll ever see them + (unless (and (equalp prev-name "li") + (equalp (car prev-operands) "imm0")) + (error "Can't determine throw count for ~s" instr)) + (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift))))) + ((.SPprogvsave + .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg + .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector + .SPstkconslist .SPstkconslist-star + .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init + .SPstkvcell0 .SPstkvcellvsp + .SPsave-values) + (values :tsp-push nil nil 1)) + (.SPrecover-values + (values :tsp-pop nil nil 1)) + (t :regular)))) + ((or (equalp name "lwz") (equalp name "addi")) + (if (equalp (car operands) "tsp") + (values :tsp-pop nil nil 1) + :regular)) + ((equalp name "stwu") + (if (equalp (car operands) "tsp") + (values :tsp-push nil nil 1) + :regular)) + ((member name '("ba" "blr" "bctr") :test 'equalp) + (values :branch nil nil)) + ; It would probably be faster to determine the branch address by adding the PC and the offset. + ((equalp name "b") + (values :branch (branch-label-address instr (car (last operands))) nil)) + ((and opcode-p (eql (opcode-majorop opcode) 16)) + (values :branch (branch-label-address instr (car (last operands))) (+ pc 4))) + (t :regular)))))) + +(defun branch-label-address (instr label-name &aux (next instr)) + (loop + (setq next (dll-node-succ next)) + (when (eq next instr) + (error "Couldn't find label ~s" label-name)) + (when (and (typep next 'lap-label) + (eq (lap-label-name next) label-name)) + (return (instruction-element-address next))))) + +(defun dll-pc->instr (dll pc) + (let ((next (dll-node-succ dll))) + (loop + (when (eq next dll) + (error "Couldn't find pc: ~s in ~s" pc dll)) + (when (eql (instruction-element-address next) pc) + (return next)) + (setq next (dll-node-succ next))))) + +(defun exception-frame-p (frame) + (fake-stack-frame-p frame)) + +(defun arg-check-call-arguments (frame function) + (declare (ignore function)) + (xp-argument-list (%fake-stack-frame.xp frame))) Index: /branches/event-ide/ccl/lib/systems.lisp =================================================================== --- /branches/event-ide/ccl/lib/systems.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/systems.lisp (revision 8262) @@ -181,6 +181,6 @@ (edit-callers "ccl:bin;edit-callers" ("ccl:lib;edit-callers.lisp")) - (hash-cons "ccl:library;hash-cons" ("ccl:library;hash-cons.lisp")) -; (step "ccl:bin;step" ("ccl:lib;step.lisp")) + ;; (hash-cons "ccl:library;hash-cons" ("ccl:library;hash-cons.lisp")) + ;; (step "ccl:bin;step" ("ccl:lib;step.lisp")) (ccl-export-syms "ccl:bin;ccl-export-syms" ("ccl:lib;ccl-export-syms.lisp")) (systems "ccl:bin;systems" ("ccl:lib;systems.lisp")) Index: /branches/event-ide/ccl/lib/time.lisp =================================================================== --- /branches/event-ide/ccl/lib/time.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/time.lisp (revision 8262) @@ -32,10 +32,14 @@ (%stack-block ((copy (* timeval-size 5))) (#_memmove copy *total-gc-microseconds* (* timeval-size 5)) - (values - (timeval->milliseconds copy) - (timeval->milliseconds (%incf-ptr copy timeval-size)) - (timeval->milliseconds (%incf-ptr copy timeval-size)) - (timeval->milliseconds (%incf-ptr copy timeval-size)) - (timeval->milliseconds (%incf-ptr copy timeval-size)))))) + (macrolet ((funk (arg) + (ecase internal-time-units-per-second + (1000000 `(timeval->microseconds ,arg)) + (1000 `(timeval->milliseconds ,arg))))) + (values + (funk copy) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size))))))) (defun get-universal-time () Index: /branches/event-ide/ccl/lib/x86-backtrace.lisp =================================================================== --- /branches/event-ide/ccl/lib/x86-backtrace.lisp (revision 8261) +++ /branches/event-ide/ccl/lib/x86-backtrace.lisp (revision 8262) @@ -95,4 +95,25 @@ bad))) +(defun %raw-frame-set (frame context idx new) + (declare (fixnum frame idx)) + (let* ((base (parent-frame frame context)) + (raw-size (- base frame))) + (declare (fixnum base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (setf (oldest-binding-frame-value context addr) new) + (setf (%fixnum-ref addr) new)))))))) + (defun %stack< (index1 index2 &optional context) (let* ((tcr (if context (bt.tcr context) (%current-tcr))) @@ -153,7 +174,54 @@ (get-register-value nil last-catch index))) +(defun %set-register-argument-value (context cfp regval new) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp (child-frame frame context)) + (first t)) + ((null frame)) + (if (xcf-p frame) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp)) + (return-from %set-register-argument-value + (setf (encoded-gpr-lisp xp regval) new))) + (progn + (unless first + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + + (return-from %set-register-argument-value + (raw-frame-set frame context where new))))))) + (setq first nil)))) + (set-register-value new nil last-catch index))) + ;;; Used for printing only. (defun index->address (p) (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0) (ash p target::fixnumshift))) + +(defun exception-frame-p (x) + (and x (xcf-p x))) + +;;; Function has failed a number-of-arguments check; return a list +;;; of the actual arguments. +;;; On x86-64, the kernel has finished the frame and pushed everything +;;; for us, so all that we need to do is to hide any inherited arguments. +(defun arg-check-call-arguments (fp function) + (when (xcf-p fp) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp)) + (let* ((numinh (ldb $lfbits-numinh (lfun-bits function))) + (nargs (- (xp-argument-count xp) numinh)) + (p (- (%fixnum-ref fp target::xcf.backptr) + (* target::node-size numinh)))) + (declare (fixnum numing nargs p)) + (collect ((args)) + (dotimes (i nargs (args)) + (args (%fixnum-ref p (- target::node-size))) + (decf p))))))) (defun vsp-limits (frame context) @@ -177,4 +245,12 @@ catch (next-catch catch)))))) +(defun last-xcf-since (target-fp start-fp context) + (do* ((last-xcf nil) + (fp start-fp (parent-frame fp context))) + ((or (eql fp target-fp) + (null fp) + (%stack< target-fp fp)) last-xcf) + (if (xcf-p fp) (setq last-xcf fp)))) + (defun match-local-name (cellno info pc) (when info @@ -187,2 +263,177 @@ (%i< pc (uvref ptrs (%i+ j 2))) (return (aref syms i)))))))) + +(defun apply-in-frame (frame function arglist &optional context) + (setq function (coerce-to-function function)) + (let* ((parent (parent-frame frame context))) + (when parent + (if (xcf-p parent) + (error "Can't unwind to exception frame ~s" frame) + (setq frame parent)) + (if (or (null context) + (eq (bt.tcr context) (%current-tcr))) + (%apply-in-frame frame function arglist) + (let* ((process (tcr->process (bt.tcr context)))) + (if process + (process-interrupt process #'%apply-in-frame frame function arglist) + (error "Can't find process for backtrace context ~s" context))))))) + +(defun return-from-frame (frame &rest values) + (apply-in-frame frame #'values values nil)) + + +(defun last-tsp-before (target) + (declare (fixnum target)) + (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) + (%fixnum-ref tsp target::tsp-frame.backptr))) + ((zerop tsp) nil) + (declare (fixnum tsp)) + (when (> (the fixnum (%fixnum-ref tsp target::tsp-frame.rbp)) + target) + (return tsp)))) + + + + +;;; We can't determine this reliably (yet). +(defun last-foreign-sp-before (target) + (declare (fixnum target)) + (do* ((cfp (%fixnum-ref (%current-tcr) target::tcr.foreign-sp) + (%fixnum-ref cfp target::csp-frame.backptr))) + ((zerop cfp)) + (declare (fixnum cfp)) + (let* ((rbp (%fixnum-ref cfp target::csp-frame.rbp))) + (declare (fixnum rbp)) + (if (> rbp target) + (return cfp) + (if (zerop rbp) + (return nil)))))) + + +(defun %tsp-frame-containing-progv-binding (db) + (declare (fixnum db)) + (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) next) + (next (%fixnum-ref tsp target::tsp-frame.backptr) + (%fixnum-ref tsp target::tsp-frame.backptr))) + () + (declare (fixnum tsp next)) + (let* ((rbp (%fixnum-ref tsp target::tsp-frame.rbp))) + (declare (fixnum rbp)) + (if (zerop rbp) + (return (values nil nil)) + (if (and (> db tsp) + (< db next)) + (return (values tsp rbp))))))) + + + + + + +(defun last-binding-before (frame) + (declare (fixnum frame)) + (do* ((db (%current-db-link) (%fixnum-ref db 0)) + (tcr (%current-tcr)) + (vs-area (%fixnum-ref tcr target::tcr.vs-area)) + (vs-low (%fixnum-ref vs-area target::area.low)) + (vs-high (%fixnum-ref vs-area target::area.high))) + ((eql db 0) nil) + (declare (fixnum db vs-low vs-high)) + (if (and (> db vs-low) + (< db vs-high)) + (if (> db frame) + (return db)) + ;; db link points elsewhere; PROGV uses the temp stack + ;; to store an indefinite number of bindings. + (multiple-value-bind (tsp rbp) + (%tsp-frame-containing-progv-binding db) + (if tsp + (if (> rbp frame) + (return db) + ;; If the tsp frame is too young, we can skip + ;; all of the bindings it contains. The tsp + ;; frame contains two words of overhead, followed + ;; by a count of binding records in the frame, + ;; followed by the youngest of "count" binding + ;; records (which happens to be the value of + ;; "db".) Skip "count" binding records. + (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size))) + (setq db (%fixnum-ref db 0)))) + ;; If the binding record wasn't on the temp stack and wasn't + ;; on the value stack, that probably means that things are + ;; seriously screwed up. This error will be almost + ;; meaningless to the user. + (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db)))))) + + + +(defun find-x8664-saved-nvrs (frame start-fp context) + (let* ((locations (make-array 16 :initial-element nil)) + (need (logior (ash 1 x8664::save0) + (ash 1 x8664::save1) + (ash 1 x8664::save2) + (ash 1 x8664::save3)))) + (declare (fixnum have need) + (dynamic-extent locations)) + (do* ((parent frame child) + (child (child-frame parent context) (child-frame child context))) + ((or (= need 0) (eq child start-fp)) + (values (%svref locations x8664::save0) + (%svref locations x8664::save1) + (%svref locations x8664::save2) + (%svref locations x8664::save3))) + (multiple-value-bind (lfun pc) (cfp-lfun child) + (when (and lfun pc) + (multiple-value-bind (used where) (registers-used-by lfun pc) + (when (and used where (logtest used need)) + (locally (declare (fixnum used)) + (do* ((i x8664::save3 (1+ i))) + ((or (= i 16) (= used 0))) + (declare (type (mod 16) i)) + (when (logbitp i used) + (when (logbitp i need) + (setq need (logandc2 need (ash 1 i))) + (setf (%svref locations i) + (- (the fixnum (1- parent)) + (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i))))))))) + (setq used (logandc2 used (ash 1 i))))))))))))) + + + +(defun %apply-in-frame (frame function arglist) + (let* ((target-catch (last-catch-since frame nil)) + (start-fp (if target-catch + (uvref target-catch target::catch-frame.rbp-cell) + (%get-frame-ptr))) + (target-xcf (last-xcf-since frame start-fp nil)) + (target-db-link (last-binding-before frame)) + (target-tsp (last-tsp-before frame)) + (target-foreign-sp (last-foreign-sp-before frame))) + (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc) + (find-x8664-saved-nvrs frame start-fp nil) + (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto + frame + target-catch + target-db-link + target-xcf + target-tsp + target-foreign-sp + (if save0-loc + (- save0-loc frame) + 0) + (if save1-loc + (- save1-loc frame) + 0) + (if save2-loc + (- save2-loc frame) + 0) + (if save3-loc + (- save3-loc frame) + 0) + (coerce-to-function function) + arglist + 0))) + (funcall thunk))))) + + + Index: /branches/event-ide/ccl/library/elf.lisp =================================================================== --- /branches/event-ide/ccl/library/elf.lisp (revision 8262) +++ /branches/event-ide/ccl/library/elf.lisp (revision 8262) @@ -0,0 +1,310 @@ +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :elf)) + + + +;;; String tables: used both for symbol names and for section names. +(defstruct elf-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +;;; Collect info about Elf symbols. +(defstruct elf-symbol-table + (strings (make-elf-string-table)) + data ; foreign pointer + nsyms + ) + +;;; Wrapper around libelf's "elf" pointer +(defstruct elf-object + libelf-pointer + fd + pathname + ) + + +;;; Is libelf thread-safe ? Who knows, there's no +;;; documentation ... +(defun libelf-error-string (&optional (errnum -1)) + (let* ((p (#_elf_errmsg errnum))) + (if (%null-ptr-p p) + (format nil "ELF error ~d" errnum) + (%get-cstring p)))) + +(defloadvar *checked-libelf-version* nil) + +(defun check-libelf-version () + (or *checked-libelf-version* + (progn + (open-shared-library "libelf.so") + (let* ((version (#_elf_version #$EV_CURRENT))) + (if (eql #$EV_NONE version) + (error "ELF library initialization failed: ~a" (libelf-error-string))) + (setq *checked-libelf-version* version))))) + + +;;; Prepate to create an ELF object file at PATHNAME, overwriting +;;; whatever might have been there. +(defun create-elf-object (pathname) + (let* ((namestring (native-translated-namestring pathname)) + (fd (ccl::fd-open namestring + (logior #$O_RDWR #$O_CREAT #$O_TRUNC) + #o755))) + (if (< fd 0) + (signal-file-error fd pathname) + (progn + (check-libelf-version) + (let* ((ptr (#_elf_begin fd #$ELF_C_WRITE +null-ptr+))) + (if (%null-ptr-p ptr) + (error "Can't initialize libelf object for ~s: ~a" + pathname (libelf-error-string)) + (make-elf-object :libelf-pointer (assert-pointer-type ptr :lf) + :fd fd + :pathname pathname))))))) + +(defun elf-end (object) + (#_elf_end (elf-object-libelf-pointer object)) + (setf (elf-object-libelf-pointer object) nil + (elf-object-fd object) nil)) + +(defun new-elf-file-header (object format type machine) + (let* ((ehdr (#_elf64_newehdr (elf-object-libelf-pointer object)))) + (if (%null-ptr-p ehdr) + (error "Can't create ELF file header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (progn + (setf (paref (pref ehdr :lf64_hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format + (pref ehdr :lf64_hdr.e_machine) machine + (pref ehdr :lf64_hdr.e_type) type + (pref ehdr :lf64_hdr.e_version) *checked-libelf-version*) + (assert-pointer-type ehdr :lf64_hdr))))) + +(defun new-elf-program-header (object &optional (count 1)) + (let* ((phdr (#_elf64_newphdr (elf-object-libelf-pointer object) count))) + (if (%null-ptr-p phdr) + (error "Can't create ELF program header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type phdr :lf64_

hdr)))) + +(defun new-elf-section (object) + (let* ((scn (#_elf_newscn (elf-object-libelf-pointer object)))) + (if (%null-ptr-p scn) + (error "Can' create ELF section for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type scn :lf_cn)))) + +(defun elf-section-header-for-section (object section) + (let* ((shdr (#_elf64_getshdr section))) + (if (%null-ptr-p shdr) + (error "Can' obtain ELF section header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type shdr :lf64_hdr)))) + +(defun elf-data-pointer-for-section (object section) + (let* ((data (#_elf_newdata section))) + (if (%null-ptr-p data) + (error "Can' obtain ELF data pointer for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type data :lf_ata)))) + + +(defun elf-register-string (string table) + (let* ((hash (elf-string-table-hash table)) + (s (elf-string-table-string table))) + (when (gethash string hash) + (format t "~& duplicate: ~s" string)) + (or (gethash string hash) + (setf (gethash string hash) + (let* ((n (length s))) + (dotimes (i (length string) (progn (vector-push-extend 0 s) n)) + (let* ((code (char-code (char string i)))) + (declare (type (mod #x110000 code))) + (if (> code 255) + (vector-push-extend (char-code #\sub) s) + (vector-push-extend code s))))))))) + + +(defun elf-lisp-function-name (f) + (let* ((name (format nil "~s" f))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + +(defx86lapfunction dynamic-dnode ((x arg_z)) + (movq (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subq (% arg_y) (% imm0)) + (shrq ($ x8664::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defun collect-elf-static-functions () + (collect ((functions)) + (freeze) + (block walk + (let* ((frozen-dnodes (frozen-space-dnodes))) + (%map-areas (lambda (o) + (when (>= (dynamic-dnode o) frozen-dnodes) + (return-from walk nil)) + (when (typep o 'function-vector) + (functions (function-vector-to-function o)))) + ccl::area-dynamic + ccl::area-dynamic + ))) + (functions))) + +(defun register-elf-functions (section-number) + (let* ((functions (collect-elf-static-functions)) + (n (length functions)) + (data (#_calloc (1+ n) (record-length :lf64_ym))) + (string-table (make-elf-string-table))) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (p (%inc-ptr data (record-length :lf64_ym)) (progn (%incf-ptr p (record-length :lf64_ym)) p)) + (f (pop functions) (pop functions))) + ((= i n) + (make-elf-symbol-table :strings string-table :data data :nsyms n)) + (declare (fixnum n)) + (setf (pref p :lf64_ym.st_name) (elf-register-string (elf-lisp-function-name f) string-table) + (pref p :lf64_ym.st_info) (logior (ash #$STB_GLOBAL 4) #$STT_FUNC) + (pref p :lf64_ym.st_shndx) section-number + (pref p :lf64_ym.st_value) (%address-of f) + (pref p :lf64_ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift)))))) + +(defun elf-section-index (section) + (#_elf_ndxscn section)) + +(defun elf-set-shstrab-section (object scn) + #+freebsd-target + (#_elf_setshstrndx (elf-object-libelf-pointer object) (elf-section-index scn)) + #-freebsd-target + (declare (ignore object scn))) + + +(defun elf-init-section-data-from-string-table (object section string-table) + (let* ((strings-data (elf-data-pointer-for-section object section)) + (s (elf-string-table-string string-table)) + (bytes (array-data-and-offset s)) + (n (length s)) + (buf (#_malloc n))) + (%copy-ivector-to-ptr bytes 0 buf 0 n) + (setf (pref strings-data :lf_ata.d_align) 1 + (pref strings-data :lf_ata.d_off) 0 + (pref strings-data :lf_ata.d_type) #$ELF_T_BYTE + (pref strings-data :lf_ata.d_version) #$EV_CURRENT + (pref strings-data :lf_ata.d_size) n + (pref strings-data :lf_ata.d_buf) buf) + n)) + +(defun elf-init-symbol-section-from-symbol-table (object section symbols) + (let* ((symbols-data (elf-data-pointer-for-section object section)) + (buf (elf-symbol-table-data symbols)) + (nsyms (elf-symbol-table-nsyms symbols) ) + (n (* (1+ nsyms) (record-length :lf64_ym)))) + (setf (pref symbols-data :lf_ata.d_align) 8 + (pref symbols-data :lf_ata.d_off) 0 + (pref symbols-data :lf_ata.d_type) #$ELF_T_SYM + (pref symbols-data :lf_ata.d_version) #$EV_CURRENT + (pref symbols-data :lf_ata.d_size) n + (pref symbols-data :lf_ata.d_buf) buf) + nsyms)) + +(defun elf-make-empty-data-for-section (object section &optional (size 0)) + (let* ((data (elf-data-pointer-for-section object section)) + (buf +null-ptr+)) + (setf (pref data :lf_ata.d_align) 0 + (pref data :lf_ata.d_off) 0 + (pref data :lf_ata.d_type) #$ELF_T_BYTE + (pref data :lf_ata.d_version) #$EV_CURRENT + (pref data :lf_ata.d_size) size + (pref data :lf_ata.d_buf) buf) + 0)) + + +(defun elf-flag-phdr (object cmd flags) + (#_elf_flagphdr (elf-object-libelf-pointer object) cmd flags)) + +(defun elf-update (object cmd) + (let* ((size (#_elf_update (elf-object-libelf-pointer object) cmd))) + (if (< size 0) + (error "elf_update failed for for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + size))) + +(defun fixup-lisp-section-offset (fd eof sectnum) + (fd-lseek fd 0 #$SEEK_SET) + (rlet ((fhdr :lf64_hdr) + (shdr :lf64_hdr)) + (fd-read fd fhdr (record-length :lf64_hdr)) + (let* ((pos (+ (pref fhdr :lf64_hdr.e_shoff) + (* sectnum (pref fhdr :lf64_hdr.e_shentsize))))) + (fd-lseek fd pos #$SEEK_SET) + (fd-read fd shdr (record-length :lf64_hdr)) + (setf (pref shdr :lf64_hdr.sh_offset) + (+ #x2000 (logandc2 (+ eof 4095) 4095))) ; #x2000 for nilreg-area + (fd-lseek fd pos #$SEEK_SET) + (fd-write fd shdr (record-length :lf64_hdr)) + t))) + +(defun write-elf-symbols-to-file (pathname) + (let* ((object (create-elf-object pathname)) + (file-header (new-elf-file-header object #$ELFDATA2LSB #$ET_DYN #$EM_X86_64)) + (program-header (new-elf-program-header object)) + (lisp-section (new-elf-section object)) + (symbols-section (new-elf-section object)) + (strings-section (new-elf-section object)) + (shstrtab-section (new-elf-section object)) + (section-names (make-elf-string-table)) + (lisp-section-index (elf-section-index lisp-section)) + (symbols (register-elf-functions lisp-section-index)) + (lisp-section-header (elf-section-header-for-section object lisp-section)) + (symbols-section-header (elf-section-header-for-section object symbols-section)) + (strings-section-header (elf-section-header-for-section object strings-section)) + (shstrtab-section-header (elf-section-header-for-section object shstrtab-section))) + + (setf (pref file-header :lf64_hdr.e_shstrndx) (elf-section-index shstrtab-section)) + (setf (pref lisp-section-header :lf64_hdr.sh_name) (elf-register-string ".lisp" section-names) + (pref lisp-section-header :lf64_hdr.sh_type) #$SHT_NOBITS + (pref lisp-section-header :lf64_hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR) + (pref lisp-section-header :lf64_hdr.sh_addr) (ash (%get-kernel-global heap-start) target::fixnumshift) + (pref lisp-section-header :lf64_hdr.sh_size) (ash (frozen-space-dnodes) target::dnode-shift) + (pref lisp-section-header :lf64_hdr.sh_offset) 0 + (pref lisp-section-header :lf64_hdr.sh_addralign) 1) + (setf (pref symbols-section-header :lf64_hdr.sh_name) (elf-register-string ".symtab" section-names) + (pref symbols-section-header :lf64_hdr.sh_type) #$SHT_SYMTAB + (pref symbols-section-header :lf64_hdr.sh_entsize) (record-length :lf64_ym) + (pref symbols-section-header :lf64_hdr.sh_link) (elf-section-index strings-section)) + (setf (pref strings-section-header :lf64_hdr.sh_name) (elf-register-string ".strtab" section-names) + (pref strings-section-header :lf64_hdr.sh_type) #$SHT_STRTAB + (pref strings-section-header :lf64_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (setf (pref shstrtab-section-header :lf64_hdr.sh_name) (elf-register-string ".shstrtab" section-names) + (pref shstrtab-section-header :lf64_hdr.sh_type) #$SHT_STRTAB + (pref shstrtab-section-header :lf64_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (elf-make-empty-data-for-section object lisp-section (ash (frozen-space-dnodes) target::dnode-shift)) + (elf-init-section-data-from-string-table object strings-section (elf-symbol-table-strings symbols)) + (elf-init-section-data-from-string-table object shstrtab-section section-names) + (elf-init-symbol-section-from-symbol-table object symbols-section symbols) + ;; Prepare in-memory data structures. + (elf-update object #$ELF_C_NULL) + ;; Fix up the program header. + (setf (pref program-header :lf64_

hdr.p_type) #$PT_PHDR + (pref program-header :lf64_

hdr.p_offset) (pref file-header :lf64_hdr.e_phoff) + (pref program-header :lf64_

hdr.p_filesz) (#_elf64_fsize #$ELF_T_PHDR 1 #$EV_CURRENT)) + ;; Mark the program header as being dirty. + (elf-flag-phdr object #$ELF_C_SET #$ELF_F_DIRTY) + (let* ((eof (elf-update object #$ELF_C_WRITE)) + (fd (elf-object-fd object))) + (elf-end object) + (fixup-lisp-section-offset fd eof lisp-section-index) + (fd-close fd)) + pathname)) + + + + Index: /branches/event-ide/ccl/library/lispequ.lisp =================================================================== --- /branches/event-ide/ccl/library/lispequ.lisp (revision 8261) +++ /branches/event-ide/ccl/library/lispequ.lisp (revision 8262) @@ -519,4 +519,6 @@ ;; The element type as it is specialized in this implementation. array-ctype-specialized-element-type + ;; The typecode of the specialize element type, or NIL. + array-ctype-typecode ) @@ -930,4 +932,5 @@ %wrapper-slot-id-value ; "fast" SLOT-VALUE function %wrapper-set-slot-id-value ; "fast" (SETF SLOT-VALUE) function + %wrapper-cpl ; cached cpl of %wrapper-class or NIL ) @@ -956,5 +959,5 @@ (defmacro %cons-wrapper (class &optional (hash-index '(new-class-wrapper-hash-index))) - `(%istruct 'class-wrapper ,hash-index ,class nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing)) + `(%istruct 'class-wrapper ,hash-index ,class nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil)) @@ -1223,4 +1226,5 @@ nhash.find ; function: find vector-index nhash.find-new ; function: find vector-index on put + nhash.read-only ; boolean: true when read-only ) @@ -1302,5 +1306,15 @@ open-binary file-stream) - + + +(def-accessors (class-cell) %svref + nil ; 'class-cell + class-cell-name + class-cell-class + class-cell-instantiate + class-cell-extra ; wrapper in some cases + ) + +(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil)) Index: /branches/event-ide/ccl/library/x8664-linux-syscalls.lisp =================================================================== --- /branches/event-ide/ccl/library/x8664-linux-syscalls.lisp (revision 8261) +++ /branches/event-ide/ccl/library/x8664-linux-syscalls.lisp (revision 8262) @@ -25,129 +25,125 @@ -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::read 0 (:unsigned-fullword :address :unsigned-fullword) - :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::write 1 (:unsigned-fullword :address :unsigned-fullword) - :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::open 2 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::close 3 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::read 0 (:int :address :size_t) + :ssize_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::write 1 (:int :address :size_t) + :ssize_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::open 2 (:address :int :mode_t) :int :min-args 2) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::close 3 (:int) :int ) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::stat 4 (:address :address) :signed-fullword) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fstat 5 (:unsigned-fullword :address) :signed-fullword ) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lstat 6 (:address :address) :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lseek 8 (:unsigned-fullword :signed-fullword :unsigned-fullword) :signed-fullword ) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::exit 60 (:signed-fullword) :void) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fork 57 () :signed-fullword) - - - - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::link 86 (:address :address) :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::unlink 87 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chdir 80 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :unsigned-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mknod 133 (:address :unsigned-fullword :unsigned-fullword) - :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chmod 90 (:address :unsigned-fullword) :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lchown 94 (:address :unsigned-fullword :unsigned-fullword) - :signed-fullword) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lseek 8 (:int :off_t :int) :off_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::exit 60 (:int) :void) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fork 57 () :pid_t) + + + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :mode_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::link 86 (:address :address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::unlink 87 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chdir 80 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :time_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mknod 133 (:address :mode_t :dev_t) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chmod 90 (:address :mode_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lchown 94 (:address :uid_t :gid_t) + :int) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpid 39 () :pid_t) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mount 165 (:address :address :address - :unsigned-fullword - :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address) :signed-fullword ) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setuid 105 (:unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getuid 102 () :unsigned-fullword ) + :unsigned-long + :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address :int) :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setuid 105 (:uid_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getuid 102 () :uid_t ) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ptrace 101 (:unsigned-fullword - :unsigned-fullword + :pid_t :address :address) - :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned-fullword) :unsigned-fullword ) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::access 21 (:address :unsigned-fullword) :signed-fullword) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sync 162 () :unsigned-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::kill 62 (:signed-fullword :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rename 82 (:address :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mkdir 83 (:address :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rmdir 84 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup 32 (:unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pipe 22 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :unsigned-fullword ) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setgid 106 (:unsigned-fullword) :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getgid 104 () :unsigned-fullword ) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::geteuid 107 () :unsigned-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getegid 108 () :unsigned-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::acct 163 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ioctl 16 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fcntl 72 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setpgid 109 (:signed-fullword :signed-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umask 95 (:unsigned-fullword) :unsigned-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chroot 161 (:address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:unsigned-fullword :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup2 33 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getppid 110 () :unsigned-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 111 () :unsigned-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsid 112 () :signed-fullword) + :long) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned) :unsigned ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :unt) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::access 21 (:address :int) :int) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sync 162 () :void ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::kill 62 (:pid_t :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rename 82 (:address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mkdir 83 (:address :mode_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rmdir 84 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup 32 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pipe 22 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :clock_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setgid 106 (:gid_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getgid 104 () :gid_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::geteuid 107 () :uid_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getegid 108 () :gid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::acct 163 (:address) :INT ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ioctl 16 (:int :int :address) :int :min-args 2 ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fcntl 72 (:int :int :long) :int :min-args 2 ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setpgid 109 (:pid_t :gid_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umask 95 (:mode_t) :mode_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chroot 161 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:dev_t :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup2 33 (:int :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getppid 110 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 111 () :gid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsid 112 () :pid_t) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt-sigaction 13 (:unsigned-fullword :address :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getrusage 98 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getrusage 98 (:int :address) :int) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 96 (:address :address) :void) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 77 (:unsigned-fullword :unsigned-fullword) - :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:unsigned-fullword :unsigned-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:unsigned-fullword :unsigned-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socket 41 (:signed-fullword :signed-fullword :signed-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::connect 42 (:signed-fullword :address :signed-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::accept 43 (:signed-fullword :address :address) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendto 44 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 45 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 46 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 47 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::shutdown 48 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bind 49 (:signed-fullword :address :signed-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bind 49 (:signed-fullword :address :signed-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::listen 50 (:signed-fullword :signed-fullword) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockname 51 (:signed-fullword :address :address) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpeername 52 (:signed-fullword :address :address) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socketpair 53 (:signed-fullword :signed-fullword :signed-fullword :address) - :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 54 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 55 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) - -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fsync 118 (:unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::uname 63 (:address) :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchdir 133 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 77 (:int :off_t) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:int :mode_t) + :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socket 41 (:int :int :int) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::connect 42 (:int :address :socklen_t) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::accept 43 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendto 44 (:int :address :size_t :int :address :socklen_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 45 (:int :address :size_t :int :address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 46 (:int :address :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 47 (:int :address :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::shutdown 48 (:int :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bind 49 (:int :address :socklen_t) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::listen 50 (:int :int) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockname 51 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpeername 52 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socketpair 53 (:int :int :int :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 54 (:int :int :int :address :socklen_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 55 (:int :int :int :address :address) :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fsync 118 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::uname 63 (:address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchdir 133 (:int) :int ) (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_llseek 140 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::select 23 (:unsigned-fullword :address :address +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::select 23 (:int :address :address :address :address) - :signed-fullword) -(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getcwd 79 (:address :unsigned-fullword) :signed-fullword ) - - + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getcwd 79 (:address :unsigned-long) :long ) + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::futex 202 (:address :int :int :address :address :int) :int ) #+notdefinedyet Index: /branches/event-ide/ccl/lisp-kernel/Threads.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/Threads.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/Threads.h (revision 8262) @@ -37,9 +37,14 @@ #include #endif + #include + #ifdef FREEBSD #include #endif + +#ifndef WINDOWS #include +#endif #include "lisp.h" @@ -47,5 +52,18 @@ #include "gc.h" +#ifdef USE_FUTEX +#include +#include +#endif + +#ifndef WINDOWS +#include +#endif + Boolean extern threads_initialized; +Boolean extern log_tcr_info; + +#define LOCK_SPINLOCK(x,tcr) get_spin_lock(&(x),tcr) +#define RELEASE_SPINLOCK(x) (x)=0 #define TCR_TO_TSD(tcr) ((void *)((natural)(tcr)+TCR_BIAS)) @@ -56,4 +74,5 @@ #define SEM_WAIT(s) sem_wait((SEMAPHORE)s) #define SEM_RAISE(s) sem_post((SEMAPHORE)s) +#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0) #define SEM_TIMEDWAIT(s,t) sem_timedwait((SEMAPHORE)s,(struct timespec *)t) #endif @@ -63,4 +82,5 @@ #define SEM_WAIT(s) semaphore_wait((SEMAPHORE)(natural)s) #define SEM_RAISE(s) semaphore_signal((SEMAPHORE)(natural)s) +#define SEM_BROADCAST(s,count)semaphore_signal_all((SEMAPHORE)(natural)s) #define SEM_TIMEDWAIT(s,t) semaphore_timedwait((SEMAPHORE)(natural)s,t) #endif @@ -121,33 +141,28 @@ Boolean resume_tcr(TCR *); -typedef struct _rwquentry -{ - struct _rwquentry *prev; - struct _rwquentry *next; - TCR *tcr; - int count; -} rwquentry; - typedef struct { - rwquentry head; - int state; /* sum of all counts on queue */ - pthread_mutex_t *lock; /* lock access to this data structure */ - pthread_cond_t *reader_signal; - pthread_cond_t *writer_signal; - int write_wait_count; - int read_wait_count; - int dying; - rwquentry freelist; + signed_natural spin; /* need spin lock to change fields */ + signed_natural state; /* 0 = free, positive if writer, negative if readers; */ + natural blocked_writers; + natural blocked_readers; + TCR *writer; +#ifdef USE_FUTEX + natural reader_signal; + natural writer_signal; +#else + void * reader_signal; + void * writer_signal; +#endif + void *malloced_ptr; } rwlock; -#define RWLOCK_WRITER(rw) rw->head.tcr -#define RWLOCK_WRITE_COUNT(rw) rw->head.count rwlock * rwlock_new(void); -int rwlock_destroy(rwlock *); +void rwlock_destroy(rwlock *); int rwlock_rlock(rwlock *, TCR *, struct timespec *); int rwlock_wlock(rwlock *, TCR *, struct timespec *); int rwlock_try_wlock(rwlock *, TCR *); +int rwlock_try_rlock(rwlock *, TCR *); int rwlock_unlock(rwlock *, TCR *); Index: /branches/event-ide/ccl/lisp-kernel/darwinppc/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/darwinppc/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/darwinppc/Makefile (revision 8262) @@ -59,10 +59,10 @@ $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ .c.o: - $(CC) -c -arch ppc $< $(CDEFINES) $(CDEBUG) $(COPT) -Wno-deprecated-declarations $(MDYNAMIC_NO_PIC) -o $@ + $(CC) -c -arch ppc $< $(CDEFINES) $(CDEBUG) $(COPT) -Wno-deprecated-declarations -mmacosx-version-min=10.3.9 $(MDYNAMIC_NO_PIC) -o $@ SPOBJ = ppc-spjump.o ppc-spentry.o ppc-subprims.o ASMOBJ = ppc-asmutils.o imports.o -COBJ = pmcl-kernel.o ppc-gc.o bits.o ppc-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ thread_manager.o lisp-debug.o image.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/darwinppc64/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/darwinppc64/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/darwinppc64/Makefile (revision 8262) @@ -62,10 +62,10 @@ $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ .c.o: - $(CC) -c $< -arch ppc64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -o $@ + $(CC) -c $< -arch ppc64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.3.9 -o $@ SPOBJ = ppc-spjump.o ppc-spentry.o ppc-subprims.o ASMOBJ = ppc-asmutils.o imports.o -COBJ = pmcl-kernel.o ppc-gc.o bits.o ppc-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ thread_manager.o lisp-debug.o image.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/darwinx8664/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/darwinx8664/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/darwinx8664/Makefile (revision 8262) @@ -55,10 +55,10 @@ $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ .c.o: - $(CC) -c $< -arch x86_64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -o $@ + $(CC) -c $< -arch x86_64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.4 -isysroot /Developer/SDKs/MacOSX10.4u.sdk -o $@ SPOBJ = x86-spjump64.o x86-spentry64.o x86-subprims64.o ASMOBJ = x86-asmutils64.o imports.o -COBJ = pmcl-kernel.o x86-gc.o bits.o x86-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ thread_manager.o lisp-debug.o image.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/errors.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/errors.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/errors.s (revision 8262) @@ -25,4 +25,5 @@ error_excised_function_call = 6 error_too_many_values = 7 +error_propagate_suspend = 10 error_cant_call = 17 Index: /branches/event-ide/ccl/lisp-kernel/freebsdx8664/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/freebsdx8664/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/freebsdx8664/Makefile (revision 8262) @@ -31,5 +31,5 @@ ASMOBJ = x86-asmutils64.o imports.o -COBJ = pmcl-kernel.o x86-gc.o bits.o x86-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ image.o thread_manager.o lisp-debug.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/gc-common.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/gc-common.c (revision 8262) +++ /branches/event-ide/ccl/lisp-kernel/gc-common.c (revision 8262) @@ -0,0 +1,1222 @@ +/* + Copyright (C) 1994-2001 Digitool, Inc + This file is part of OpenMCL. + + OpenMCL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with OpenMCL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with OpenMCL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + OpenMCL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "bits.h" +#include "gc.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include + +#ifndef timeradd +# define timeradd(a, b, result) \ + do { \ + (result)->tv_sec = (a)->tv_sec + (b)->tv_sec; \ + (result)->tv_usec = (a)->tv_usec + (b)->tv_usec; \ + if ((result)->tv_usec >= 1000000) \ + { \ + ++(result)->tv_sec; \ + (result)->tv_usec -= 1000000; \ + } \ + } while (0) +#endif +#ifndef timersub +# define timersub(a, b, result) \ + do { \ + (result)->tv_sec = (a)->tv_sec - (b)->tv_sec; \ + (result)->tv_usec = (a)->tv_usec - (b)->tv_usec; \ + if ((result)->tv_usec < 0) { \ + --(result)->tv_sec; \ + (result)->tv_usec += 1000000; \ + } \ + } while (0) +#endif + +void +comma_output_decimal(char *buf, int len, natural n) +{ + int nout = 0; + + buf[--len] = 0; + do { + buf[--len] = n%10+'0'; + n = n/10; + if (n == 0) { + while (len) { + buf[--len] = ' '; + } + return; + } + if (len == 0) return; + nout ++; + if (nout == 3) { + buf[--len] = ','; + nout = 0; + } + } while (len >= 0); +} + + +natural +static_dnodes_for_area(area *a) +{ + if (a->low == tenured_area->low) { + return tenured_area->static_dnodes; + } + return 0; +} + +Boolean GCDebug = false, GCverbose = false; +bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL; +LispObj GCarealow = 0, GCareadynamiclow = 0; +natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0; +LispObj GCweakvll = (LispObj)NULL; +LispObj GCephemeral_low = 0; +natural GCn_ephemeral_dnodes = 0; +natural GCstack_limit = 0; + + +void +reapweakv(LispObj weakv) +{ + /* + element 2 of the weak vector should be tagged as a cons: if it + isn't, just mark it as a root. if it is, cdr through it until a + "marked" cons is encountered. If the car of any unmarked cons is + marked, mark the cons which contains it; otherwise, splice the + cons out of the list. N.B. : elements 0 and 1 are already marked + (or are immediate, etc.) + */ + LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev; + LispObj termination_list = lisp_nil; + natural weak_type = (natural) deref(weakv,2); + Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist), + terminatablep = ((weak_type >> population_termination_bit) != 0); + Boolean done = false; + cons *rawcons; + natural dnode, car_dnode; + bitvector markbits = GCmarkbits; + + if (terminatablep) { + termination_list = deref(weakv,1+3); + } + + if (fulltag_of(cell) != fulltag_cons) { + mark_root(cell); + } else if (alistp) { + /* weak alist */ + while (! done) { + dnode = gc_area_dnode(cell); + if ((dnode >= GCndnodes_in_area) || + (ref_bit(markbits, dnode))) { + done = true; + } else { + /* Cons cell is unmarked. */ + LispObj alist_cell, thecar; + unsigned cell_tag; + + rawcons = (cons *) ptr_from_lispobj(untag(cell)); + alist_cell = rawcons->car; + cell_tag = fulltag_of(alist_cell); + + if ((cell_tag == fulltag_cons) && + ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode)) && + (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) && + ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode))) { + *prev = rawcons->cdr; + if (terminatablep) { + rawcons->cdr = termination_list; + termination_list = cell; + } + } else { + set_bit(markbits, dnode); + prev = (LispObj *)(&(rawcons->cdr)); + mark_root(alist_cell); + } + cell = *prev; + } + } + } else { + /* weak list */ + while (! done) { + dnode = gc_area_dnode(cell); + if ((dnode >= GCndnodes_in_area) || + (ref_bit(markbits, dnode))) { + done = true; + } else { + /* Cons cell is unmarked. */ + LispObj thecar; + unsigned cartag; + + rawcons = (cons *) ptr_from_lispobj(untag(cell)); + thecar = rawcons->car; + cartag = fulltag_of(thecar); + + if (is_node_fulltag(cartag) && + ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode))) { + *prev = rawcons->cdr; + if (terminatablep) { + rawcons->cdr = termination_list; + termination_list = cell; + } + } else { + set_bit(markbits, dnode); + prev = (LispObj *)(&(rawcons->cdr)); + } + cell = *prev; + } + } + } + + if (terminatablep) { + deref(weakv,1+3) = termination_list; + if (termination_list != lisp_nil) { + deref(weakv,1) = GCweakvll; + GCweakvll = weakv; + } + } +} + +/* + Screw: doesn't deal with finalization. + */ + +void +reaphashv(LispObj hashv) +{ + hash_table_vector_header + *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv)); + natural + dnode, + npairs = (header_element_count(hashp->header) - + ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1; + LispObj *pairp = (LispObj*) (hashp+1), weakelement; + Boolean + weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); + bitvector markbits = GCmarkbits; + int tag; + + while (npairs--) { + if (weak_on_value) { + weakelement = pairp[1]; + } else { + weakelement = pairp[0]; + } + tag = fulltag_of(weakelement); + if (is_node_fulltag(tag)) { + dnode = gc_area_dnode(weakelement); + if ((dnode < GCndnodes_in_area) && + ! ref_bit(markbits, dnode)) { + pairp[0] = slot_unbound; + pairp[1] = lisp_nil; + hashp->weak_deletions_count += (1<flags, key_dnode, val_dnode; + Boolean + marked_new = false, + key_marked, + val_marked, + weak_value = ((flags & nhash_weak_value_mask) != 0); + int + skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1, + key_tag, + val_tag, + i; + LispObj + *pairp = (LispObj*) (hashp+1), + key, + val; + + /* Mark everything in the header */ + + for (i = 2; i<= skip; i++) { + mark_root(deref(ptr_to_lispobj(hashp),i)); + } + + elements -= skip; + + for (i = 0; i> population_termination_bit) { + elements -= 1; + } + for(alist = deref(weak_alist, elements); + (fulltag_of(alist) == fulltag_cons) && + ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode)); + alist = cdr(alist)) { + pair = car(alist); + pair_tag = fulltag_of(pair); + if ((is_node_fulltag(pair_tag)) && + ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode))) { + if (pair_tag == fulltag_cons) { + key = car(pair); + if ((! is_node_fulltag(fulltag_of(key))) || + ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) || + ref_bit(markbits,dnode)) { + /* key is marked, mark value if necessary */ + value = cdr(pair); + if (is_node_fulltag(fulltag_of(value)) && + ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode))) { + mark_root(value); + marked_new = true; + } + } + } else { + mark_root(pair); + marked_new = true; + } + } + } + return marked_new; +} + +void +markhtabvs() +{ + LispObj this, header, pending; + int subtag; + bitvector markbits = GCmarkbits; + hash_table_vector_header *hashp; + Boolean marked_new; + + do { + pending = (LispObj) NULL; + marked_new = false; + + while (GCweakvll) { + this = GCweakvll; + GCweakvll = deref(this,1); + + header = header_of(this); + subtag = header_subtag(header); + + if (subtag == subtag_weak) { + natural weak_type = deref(this,2); + deref(this,1) = pending; + pending = this; + if ((weak_type & population_type_mask) == population_weak_alist) { + if (mark_weak_alist(this, weak_type)) { + marked_new = true; + } + } + } else if (subtag == subtag_hash_vector) { + natural elements = header_element_count(header), i; + + hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this)); + if (hashp->flags & nhash_weak_mask) { + deref(this,1) = pending; + pending = this; + if (mark_weak_hash_vector(hashp, elements)) { + marked_new = true; + } + } else { + deref(this,1) = (LispObj)NULL; + for (i = 2; i <= elements; i++) { + mark_root(deref(this,i)); + } + } + } else { + Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this); + } + } + + if (marked_new) { + GCweakvll = pending; + } + } while (marked_new); + + /* Now, everything's marked that's going to be, and "pending" is a list + of populations and weak hash tables. CDR down that list and free + anything that isn't marked. + */ + + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + + subtag = header_subtag(header_of(this)); + if (subtag == subtag_weak) { + reapweakv(this); + } else { + reaphashv(this); + } + } + + /* Finally, mark the termination lists in all terminatable weak vectors + They are now linked together on GCweakvll. + This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, + but it will force terminatable popualations to hold on to each other + (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). + */ + pending = GCweakvll; + GCweakvll = (LispObj)NULL; + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + mark_root(deref(this,1+3)); + } +} + +void +mark_tcr_tlb(TCR *tcr) +{ + natural n = tcr->tlb_limit; + LispObj + *start = tcr->tlb_pointer, + *end = (LispObj *) ((BytePtr)start+n), + node; + + while (start < end) { + node = *start; + if (node != no_thread_local_binding_marker) { + mark_root(node); + } + start++; + } +} + +/* + Mark things that're only reachable through some (suspended) TCR. + (This basically means the tcr's gc_context and the exception + frames on its xframe_list.) +*/ + +void +mark_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + mark_xp(xp); + } + + for (xframes = (xframe_list *) tcr->xframe; + xframes; + xframes = xframes->prev) { + mark_xp(xframes->curr); + } +} + + +void *postGCptrs = NULL; + +void +postGCfree(void *p) +{ + *(void **)p = postGCptrs; + postGCptrs = p; +} + +void +freeGCptrs() +{ + void *p, *next; + + for (p = postGCptrs; p; p = next) { + next = *((void **)p); + free(p); + } + postGCptrs = NULL; +} + +void +reap_gcable_ptrs() +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr; + xmacptr_flag flag; + natural dnode; + xmacptr *x; + + while((next = *prev) != (LispObj)NULL) { + dnode = gc_area_dnode(next); + x = (xmacptr *) ptr_from_lispobj(untag(next)); + + if ((dnode >= GCndnodes_in_area) || + (ref_bit(GCmarkbits,dnode))) { + prev = &(x->link); + } else { + *prev = x->link; + flag = (xmacptr_flag)(x->flags); + ptr = x->address; + + if (ptr) { + switch (flag) { + case xmacptr_flag_recursive_lock: + destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_ptr: + postGCfree((void *)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_rwlock: + rwlock_destroy((rwlock *)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_semaphore: + destroy_semaphore((void**)&(x->address)); + break; + + default: + /* (warn "unknown xmacptr_flag: ~s" flag) */ + /* Unknowd, and perhaps unknowdable. */ + /* Fall in: */ + case xmacptr_flag_none: + break; + } + } + } + } +} + + + +#if WORD_SIZE == 64 +unsigned short *_one_bits = NULL; + +unsigned short +logcount16(unsigned short n) +{ + unsigned short c=0; + + while(n) { + n = n & (n-1); + c++; + } + return c; +} + +void +gc_init() +{ + int i; + + _one_bits = malloc(sizeof(unsigned short) * (1<<16)); + + for (i = 0; i < (1<<16); i++) { + _one_bits[i] = dnode_size*logcount16(i); + } +} + + +#else +const unsigned char _one_bits[256] = { + 0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8 +}; + + +void +gc_init() +{ +} + +#endif + +LispObj +node_forwarding_address(LispObj node) +{ + int tag_n; + natural dnode = gc_dynamic_area_dnode(node); + + if ((dnode >= GCndynamic_dnodes_in_area) || + (node < GCfirstunmarked)) { + return node; + } + + tag_n = fulltag_of(node); + if (!is_node_fulltag(tag_n)) { + return node; + } + + return dnode_forwarding_address(dnode, tag_n); +} + +Boolean +update_noderef(LispObj *noderef) +{ + LispObj + node = *noderef, + new = node_forwarding_address(node); + + if (new != node) { + *noderef = new; + return true; + } + return false; +} + +void +update_locref(LispObj *locref) +{ + LispObj + obj = *locref, + new = locative_forwarding_address(obj); + + if (new != obj) { + *locref = new; + } +} + +void +forward_gcable_ptrs() +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((next = *prev) != (LispObj)NULL) { + *prev = node_forwarding_address(next); + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + +void +forward_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2, new; + natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0; + int tag_x1; + hash_table_vector_header *hashp = NULL; + Boolean header_p; + + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* This is pretty straightforward, but we have to note + when we move a key in a hash table vector that wants + us to tell it about that. */ + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + bits = *++bitsp; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = p[0]; + x2 = p[1]; + tag_x1 = fulltag_of(x1); + bits &= ~(BIT0_MASK >> bitidx); + header_p = (nodeheader_tag_p(tag_x1)); + + if (header_p && + (header_subtag(x1) == subtag_hash_vector)) { + hashp = (hash_table_vector_header *) p; + if (hashp->flags & nhash_track_keys_mask) { + hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1); + } else { + hashp = NULL; + } + } + + + if (! header_p) { + new = node_forwarding_address(x1); + if (new != x1) { + *p = new; + } + } + p++; + + new = node_forwarding_address(x2); + if (new != x2) { + *p = new; + if (memo_dnode < hash_dnode_limit) { + hashp->flags |= nhash_key_moved_mask; + hash_dnode_limit = 0; + hashp = NULL; + } + } + p++; + memo_dnode++; + bitidx++; + + } + } +} + +void +forward_tcr_tlb(TCR *tcr) +{ + natural n = tcr->tlb_limit; + LispObj + *start = tcr->tlb_pointer, + *end = (LispObj *) ((BytePtr)start+n), + node; + + while (start < end) { + node = *start; + if (node != no_thread_local_binding_marker) { + update_noderef(start); + } + start++; + } +} + +void +reclaim_static_dnodes() +{ + natural nstatic = tenured_area->static_dnodes, i, bits, mask, bitnum; + cons *c = (cons *)tenured_area->low, *d; + bitvector bitsp = GCmarkbits; + LispObj head = lisp_global(STATIC_CONSES); + + if (nstatic) { + if (head) { + for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) { + bits = *bitsp++; + if (bits != ALL_ONES) { + for (bitnum = 0; bitnum < nbits_in_word; bitnum++) { + if (! (bits & (BIT0_MASK>>bitnum))) { + d = c + bitnum; + d->car = 0; + d->cdr = head; + head = ((LispObj)d)+fulltag_cons; + } + } + } + } + lisp_global(STATIC_CONSES) = head; + } else { + for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) { + bits = *bitsp++; + if (bits != ALL_ONES) { + for (bitnum = 0; bitnum < nbits_in_word; bitnum++) { + if (! (bits & (BIT0_MASK>>bitnum))) { + d = c + bitnum; + d->car = 0; + d->cdr = 0; + } + } + } + } + } + } +} + +Boolean +youngest_non_null_area_p (area *a) +{ + if (a->active == a->high) { + return false; + } else { + for (a = a->younger; a; a = a->younger) { + if (a->active != a->high) { + return false; + } + } + }; + return true; +} + +Boolean just_purified_p = false; + +/* + All thread's stack areas have been "normalized", as + has the dynamic heap. (The "active" pointer in these areas + matches the stack pointer/freeptr value at the time that + the exception occurred.) +*/ + + +#define get_time(when) gettimeofday(&when, NULL) + + + +#ifdef FORCE_DWS_MARK +#warning recursive marker disabled for testing; remember to re-enable it +#endif + +void +gc(TCR *tcr, signed_natural param) +{ + xframe_list *xframes = (tcr->xframe); + struct timeval start, stop; + area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; + unsigned timeidx = 1; + paging_info paging_info_start; + xframe_list *x; + LispObj + pkg, + itabvec = 0; + BytePtr oldfree = a->active; + TCR *other_tcr; + natural static_dnodes; + +#ifndef FORCE_DWS_MARK + if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { + GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; + } else { + GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size; + } +#else + GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; +#endif + + GCephemeral_low = lisp_global(OLDEST_EPHEMERAL); + if (GCephemeral_low) { + GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low); + } else { + GCn_ephemeral_dnodes = 0; + } + + if (GCn_ephemeral_dnodes) { + GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0); + } else { + GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0); + } + + if (GCephemeral_low) { + if ((oldfree-g1_area->low) < g1_area->threshold) { + to = g1_area; + note = a; + timeidx = 4; + } else if ((oldfree-g2_area->low) < g2_area->threshold) { + to = g2_area; + from = g1_area; + note = g1_area; + timeidx = 3; + } else { + to = tenured_area; + from = g2_area; + note = g2_area; + timeidx = 2; + } + } else { + note = tenured_area; + } + + if (GCverbose) { + char buf[16]; + + sample_paging_info(&paging_info_start); + comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift); + if (GCephemeral_low) { + fprintf(stderr, + "\n\n;;; Starting Ephemeral GC of generation %d", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); + } else { + fprintf(stderr,"\n\n;;; Starting full GC"); + } + fprintf(stderr, ", %s bytes allocated.\n", buf); + } + + get_time(start); + lisp_global(IN_GC) = (1<markbits; + GCarealow = ptr_to_lispobj(a->low); + GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift); + GCndnodes_in_area = gc_area_dnode(oldfree); + + if (GCndnodes_in_area) { + GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes; + GCdynamic_markbits = + GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift); + + zero_bits(GCmarkbits, GCndnodes_in_area); + GCweakvll = (LispObj)NULL; + + if (GCn_ephemeral_dnodes == 0) { + /* For GCTWA, mark the internal package hash table vector of + *PACKAGE*, but don't mark its contents. */ + { + LispObj + itab; + natural + dnode, ndnodes; + + pkg = nrs_PACKAGE.vcell; + if ((fulltag_of(pkg) == fulltag_misc) && + (header_subtag(header_of(pkg)) == subtag_package)) { + itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab; + itabvec = car(itab); + dnode = gc_area_dnode(itabvec); + if (dnode < GCndnodes_in_area) { + ndnodes = (header_element_count(header_of(itabvec))+1) >> 1; + set_n_bits(GCmarkbits, dnode, ndnodes); + } + } + } + } + + mark_root(lisp_global(STATIC_CONSES)); + + { + area *next_area; + area_code code; + + /* Could make a jump table instead of the typecase */ + + for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + mark_tstack_area(next_area); + break; + + case AREA_VSTACK: + mark_vstack_area(next_area); + break; + + case AREA_CSTACK: + mark_cstack_area(next_area); + break; + + case AREA_STATIC: + case AREA_DYNAMIC: /* some heap that isn't "the" heap */ + /* In both of these cases, we -could- use the area's "markbits" + bitvector as a reference map. It's safe (but slower) to + ignore that map and process the entire area. + */ + if (next_area->younger == NULL) { + mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active); + } + break; + + default: + break; + } + } + } + + if (lisp_global(OLDEST_EPHEMERAL)) { + mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low)); + } + + other_tcr = tcr; + do { + mark_tcr_xframes(other_tcr); + mark_tcr_tlb(other_tcr); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + + + /* Go back through *package*'s internal symbols, marking + any that aren't worthless. + */ + + if (itabvec) { + natural + i, + n = header_element_count(header_of(itabvec)); + LispObj + sym, + *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); + + for (i = 0; i < n; i++) { + sym = *raw++; + if (is_symbol_fulltag(sym)) { + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + /* Symbol is in GC area, not marked. + Mark it if fboundp, boundp, or if + it has a plist or another home package. + */ + + if (FBOUNDP(rawsym) || + BOUNDP(rawsym) || + (rawsym->flags != 0) || /* SPECIAL, etc. */ + (rawsym->plist != lisp_nil) || + ((rawsym->package_predicate != pkg) && + (rawsym->package_predicate != lisp_nil))) { + mark_root(sym); + } + } + } + } + } + + (void)markhtabvs(); + + if (itabvec) { + natural + i, + n = header_element_count(header_of(itabvec)); + LispObj + sym, + *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); + + for (i = 0; i < n; i++, raw++) { + sym = *raw; + if (is_symbol_fulltag(sym)) { + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + *raw = unbound_marker; + } + } + } + } + + reap_gcable_ptrs(); + + GCrelocptr = global_reloctab; + GCfirstunmarked = calculate_relocation(); + + if (!GCephemeral_low) { + reclaim_static_dnodes(); + } + + forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked)); + + other_tcr = tcr; + do { + forward_tcr_xframes(other_tcr); + forward_tcr_tlb(other_tcr); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + forward_gcable_ptrs(); + + + + { + area *next_area; + area_code code; + + /* Could make a jump table instead of the typecase */ + + for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + forward_tstack_area(next_area); + break; + + case AREA_VSTACK: + forward_vstack_area(next_area); + break; + + case AREA_CSTACK: + forward_cstack_area(next_area); + break; + + case AREA_STATIC: + case AREA_DYNAMIC: /* some heap that isn't "the" heap */ + if (next_area->younger == NULL) { + forward_range((LispObj *) next_area->low, (LispObj *) next_area->active); + } + break; + + default: + break; + } + } + } + + if (GCephemeral_low) { + forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); + } + + a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap()); + if (to) { + tenure_to_area(to); + } + + zero_memory_range(a->active, oldfree); + + resize_dynamic_heap(a->active, + (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0); + + /* + If the EGC is enabled: If there's no room for the youngest + generation, untenure everything. If this was a full GC and + there's now room for the youngest generation, tenure everything. + */ + if (a->older != NULL) { + natural nfree = (a->high - a->active); + + + if (nfree < a->threshold) { + untenure_from_area(tenured_area); + } else { + if (GCephemeral_low == 0) { + tenure_to_area(tenured_area); + } + } + } + } + lisp_global(GC_NUM) += (1<gccount += (1<vcell; + if ((fulltag_of(val) == fulltag_misc) && + (header_subtag(header_of(val)) == subtag_macptr)) { + timersub(&stop, &start, &elapsed); + timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address); + timeradd(timeinfo, &elapsed, timeinfo); + timeradd(timeinfo+timeidx, &elapsed, timeinfo+timeidx); + } + + val = total_bytes_freed->vcell; + if ((fulltag_of(val) == fulltag_misc) && + (header_subtag(header_of(val)) == subtag_macptr)) { + long long justfreed = oldfree - a->active; + *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed; + if (GCverbose) { + char buf[16]; + paging_info paging_info_stop; + + sample_paging_info(&paging_info_stop); + if (justfreed <= heap_segment_size) { + justfreed = 0; + } + comma_output_decimal(buf,16,justfreed); + if (note == tenured_area) { + fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec); + } else { + fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, + buf, + elapsed.tv_sec, elapsed.tv_usec); + } + report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop); + } + } + } +} Index: /branches/event-ide/ccl/lisp-kernel/gc.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/gc.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/gc.h (revision 8262) @@ -90,4 +90,10 @@ +#ifdef fulltag_symbol +#define is_symbol_fulltag(x) (fulltag_of(x) == fulltag_symbol) +#else +#define is_symbol_fulltag(x) (fulltag_of(x) == fulltag_misc) +#endif + #define area_dnode(w,low) ((natural)(((ptr_to_lispobj(w)) - ptr_to_lispobj(low))>>dnode_shift)) #define gc_area_dnode(w) area_dnode(w,GCarealow) @@ -105,4 +111,19 @@ #define VOID_ALLOCPTR ((LispObj)(-dnode_size)) #endif + +#ifdef DARWIN +#include +typedef struct task_events_info paging_info; +#else +#ifndef WINDOWS +#include +typedef struct rusage paging_info; +#endif +#endif + +#include + +void sample_paging_info(paging_info *); +void report_paging_info_delta(FILE*, paging_info *, paging_info *); @@ -118,4 +139,70 @@ #define GC_TRAP_FUNCTION_EGC_CONTROL 32 #define GC_TRAP_FUNCTION_CONFIGURE_EGC 64 -#define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 +#define GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE 128 /* deprecated */ +#define GC_TRAP_FUNCTION_FREEZE 129 +#define GC_TRAP_FUNCTION_THAW 130 + +Boolean GCDebug, GCverbose, just_purified_p; +bitvector GCmarkbits, GCdynamic_markbits; +LispObj GCarealow, GCareadynamiclow; +natural GCndnodes_in_area, GCndynamic_dnodes_in_area; +LispObj GCweakvll; +LispObj GCephemeral_low; +natural GCn_ephemeral_dnodes; +natural GCstack_limit; + +#if WORD_SIZE == 64 +unsigned short *_one_bits; +#else +const unsigned char _one_bits[256]; +#endif + +#define one_bits(x) _one_bits[x] + +natural static_dnodes_for_area(area *a); +void reapweakv(LispObj weakv); +void reaphashv(LispObj hashv); +Boolean mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements); +Boolean mark_weak_alist(LispObj weak_alist, int weak_type); +void markhtabvs(void); +void mark_tcr_tlb(TCR *); +void mark_tcr_xframes(TCR *); +void postGCfree(void *); +void freeGCptrs(void); +void reap_gcable_ptrs(void); +unsigned short logcount16(unsigned short); +void gc_init(void); +LispObj node_forwarding_address(LispObj); +Boolean update_noderef(LispObj *); +void update_locref(LispObj *); +void forward_gcable_ptrs(void); +void forward_memoized_area(area *, natural); +void forward_tcr_tlb(TCR *); +void reclaim_static_dnodes(void); +Boolean youngest_non_null_area_p(area *); +void gc(TCR *, signed_natural); + +/* backend-interface */ + +void mark_root(LispObj); +void mark_xp(ExceptionInformation *); +LispObj dnode_forwarding_address(natural, int); +LispObj locative_forwarding_address(LispObj); +void check_refmap_consistency(LispObj *, LispObj *, bitvector); +void check_all_areas(void); +void mark_tstack_area(area *); +void mark_vstack_area(area *); +void mark_cstack_area(area *); +void mark_simple_area_range(LispObj *, LispObj *); +void mark_memoized_area(area *, natural); +LispObj calculate_relocation(void); +void forward_range(LispObj *, LispObj *); +void forward_tstack_area(area *); +void forward_vstack_area(area *); +void forward_cstack_area(area *); +LispObj compact_dynamic_heap(void); +LispObj * skip_over_ivector(natural, LispObj); +int purify(TCR *, signed_natural); +int impurify(TCR *, signed_natural); + #endif /* __GC_H__ */ Index: /branches/event-ide/ccl/lisp-kernel/image.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/image.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/image.c (revision 8262) @@ -31,6 +31,11 @@ ((1<= low) && (w0 < high) && ((1<static_dnodes = sect->static_dnodes; - if (a->static_dnodes) { - natural pages_size = (align_to_power_of_2((align_to_power_of_2(a->static_dnodes, - log2_nbits_in_word)>>3), - log2_page_size)); - lseek(fd,pos+mem_size, SEEK_SET); - pos = seek_to_next_page(fd); - addr = mmap(NULL, - pages_size, - PROT_READ | PROT_WRITE, - MAP_PRIVATE, - fd, - pos); - if (addr == MAP_FAILED) { - return; - } - a->static_used = addr; - advance = pages_size; - } sect->area = a; break; @@ -371,5 +362,5 @@ count = total; } - bcopy(a->low+done,buffer,count); + memmove(buffer,a->low+done,count); n = write(fd, buffer, count); if (n < 0) { @@ -420,7 +411,7 @@ #endif - areas[0] = readonly_area; - areas[1] = nilreg_area; - areas[2] = active_dynamic_area; + areas[0] = nilreg_area; + areas[1] = active_dynamic_area; + areas[2] = readonly_area; areas[3] = managed_static_area; for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { @@ -477,5 +468,5 @@ case FWDNUM: case GC_NUM: - case DELETED_STATIC_PAIRS: + case STATIC_CONSES: break; default: @@ -503,15 +494,4 @@ return errno; } - if (nstatic) { - /* Need to write the static_used bitmap */ - natural static_used_size_in_bytes = - (align_to_power_of_2((align_to_power_of_2(nstatic, log2_nbits_in_word)>>3), - log2_page_size)); - seek_to_next_page(fd); - if (write(fd, tenured_area->static_used, static_used_size_in_bytes) - != static_used_size_in_bytes) { - return errno; - } - } } } Index: /branches/event-ide/ccl/lisp-kernel/image.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/image.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/image.h (revision 8262) @@ -90,7 +90,7 @@ -#define ABI_VERSION_MIN 1017 -#define ABI_VERSION_CURRENT 1017 -#define ABI_VERSION_MAX 1017 +#define ABI_VERSION_MIN 1019 +#define ABI_VERSION_CURRENT 1019 +#define ABI_VERSION_MAX 1019 #define NUM_IMAGE_SECTIONS 4 /* used to be 3 */ Index: /branches/event-ide/ccl/lisp-kernel/linuxppc/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/linuxppc/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/linuxppc/Makefile (revision 8262) @@ -58,5 +58,5 @@ ASMOBJ = ppc-asmutils.o imports.o -COBJ = pmcl-kernel.o ppc-gc.o bits.o ppc-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ image.o thread_manager.o lisp-debug.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/linuxppc64/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/linuxppc64/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/linuxppc64/Makefile (revision 8262) @@ -46,5 +46,5 @@ ASMOBJ = ppc-asmutils.o imports.o -COBJ = pmcl-kernel.o ppc-gc.o bits.o ppc-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ image.o thread_manager.o lisp-debug.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/linuxx8664/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/linuxx8664/Makefile (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/linuxx8664/Makefile (revision 8262) @@ -21,5 +21,5 @@ ASFLAGS = --64 M4FLAGS = -DLINUX -DX86 -DX8664 -DHAVE_TLS -CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS #-DDISABLE_EGC +CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DUSE_FUTEX #-DDISABLE_EGC CDEBUG = -g COPT = -O2 @@ -44,5 +44,5 @@ ASMOBJ = x86-asmutils64.o imports.o -COBJ = pmcl-kernel.o x86-gc.o bits.o x86-exceptions.o \ +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ image.o thread_manager.o lisp-debug.o memory.o Index: /branches/event-ide/ccl/lisp-kernel/lisp-debug.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/lisp-debug.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/lisp-debug.c (revision 8262) @@ -516,14 +516,12 @@ fprintf(stderr, "Value (lisp) stack area: low = 0x%lx, high = 0x%lx\n", vs_area->low, vs_area->high); - if (xp) { - fprintf(stderr, "Exception stack pointer = 0x%lx\n", -#ifdef PPC - xpGPR(xp,1) + fprintf(stderr, "Exception stack pointer = 0x%lx\n", +#ifdef PPC + xpGPR(xp,1) #endif #ifdef X86 - xpGPR(xp,Isp) -#endif - ); - } + xpGPR(xp,Isp) +#endif + ); } return debug_continue; @@ -866,22 +864,8 @@ fprintf(stderr, "Exception occurred while executing foreign code\n"); } + if (lisp_global(BATCH_FLAG)) { abort(); } -#ifdef DARWIN -#ifdef X8664 - if (xp) { - extern void *_sigtramp(); - extern int os_major_version; - - if (xpPC(xp) == (natural)_sigtramp) { - xp = (ExceptionInformation *) xpGPR(xp, REG_R8); - fprintf(stderr, "Exception raised at _sigtramp; using context passed to _sigtramp. Raw register values (R) may be more interesting then lisp values or lisp backtrace\n"); - } - } -#endif -#endif - - if (xp) { if (why > debug_entry_exception) { Index: /branches/event-ide/ccl/lisp-kernel/lisp-errors.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/lisp-errors.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/lisp-errors.h (revision 8262) @@ -18,16 +18,4 @@ #define __ERRORS_X 1 -/* -10/22/96 bill error_too_many_values ---- 4.0 --- -05/12/96 gb conditionalize on __ERRORS_X to avoid conflict with ---- 3.9 --- -04/10/96 gb error_memory_full -04/09/96 gb error_excised_function_call -03/01/96 gb FPU exceptions -01/22/96 gb add/rename error_alloc_failed, error_stack_overflow -12/13/95 gb add error_alloc_fail, error_throw_tag_missing. -11/09/95 gb in synch with %type-error-types%. -*/ #define error_reg_regnum 0 @@ -39,4 +27,5 @@ #define error_excised_function_call 6 #define error_too_many_values 7 +#define error_propagate_suspend 10 #define error_cant_call 17 Index: /branches/event-ide/ccl/lisp-kernel/lisp-exceptions.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/lisp-exceptions.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/lisp-exceptions.h (revision 8262) @@ -23,4 +23,8 @@ #include "gc.h" +#ifdef WINDOWS +#include +#endif + typedef enum { kDebugger, @@ -29,4 +33,8 @@ } ErrAction; + +#ifdef WINDOWS +typedef EXCEPTION_RECORD siginfo_t; /* Not even close to being the right thing to do */ +#endif @@ -146,5 +154,4 @@ void resume_other_threads(Boolean); -#define debug_foreign_exception 0x80 #endif /* __lisp_exceptions_h__ */ Index: /branches/event-ide/ccl/lisp-kernel/lisp_globals.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/lisp_globals.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/lisp_globals.h (revision 8262) @@ -33,5 +33,5 @@ #define TCR_AREA_LOCK (-11) /* all_areas/tcr queue lock */ #define EXCEPTION_LOCK (-12) /* serialize exception handling */ -#define DELETED_STATIC_PAIRS (-13) /* for hash-consing */ +#define STATIC_CONSES (-13) #define DEFAULT_ALLOCATION_QUANTUM (-14) #define INTFLAG (-15) Index: /branches/event-ide/ccl/lisp-kernel/lisptypes.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/lisptypes.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/lisptypes.h (revision 8262) @@ -30,4 +30,17 @@ +#include + +#ifdef WIN64 +#include +typedef long long s64_t; +typedef unsigned long long u64_t; +typedef signed long s32_t; +typedef unsigned long u32_t; +typedef signed short s16_t; +typedef unsigned short u16_t; +typedef signed char s8_t; +typedef unsigned char u8_t; +#else #ifdef SOLARIS /* Solaris doesn't laugh and play like the other children */ @@ -49,4 +62,5 @@ typedef int8_t s8_t; typedef u_int8_t u8_t; +#endif #endif @@ -88,5 +102,8 @@ #define UC_MCONTEXT(UC) UC->uc_mcontext #endif /* WORD_SIZE */ -#ifndef _STRUCT_UCONTEXT +#ifndef __DARWIN_UNIX03 +#define __DARWIN_UNIX03 0 +#endif +#if !__DARWIN_UNIX03 #define __ss ss #define __es es @@ -160,4 +177,8 @@ #endif +#ifdef WIN64 +typedef EXCEPTION_POINTERS ExceptionInformation; +#endif + typedef u32_t lisp_char_code; Index: /branches/event-ide/ccl/lisp-kernel/m4macros.m4 =================================================================== --- /branches/event-ide/ccl/lisp-kernel/m4macros.m4 (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/m4macros.m4 (revision 8262) @@ -28,7 +28,9 @@ define([BSDstabs],[1]) define([ELFstabs],[2]) +define([COFFstabs],[3]) undefine([EABI]) undefine([POWEROPENABI]) undefine([rTOC]) + ifdef([DARWIN],[define([SYSstabs],[BSDstabs]) @@ -69,4 +71,8 @@ define([EndTextLabel],[.Letext])]) +ifdef([WIN64],[define([SYSstabs],[COFFstabs]) + define([CNamesNeedUnderscores],[]) + define([LocalLabelPrefix],[L])]) + /* Names exported to (or imported from) C may need leading underscores. */ @@ -78,6 +84,8 @@ define([_emit_BSD_source_line_stab],[ +ifdef([X86],[ +# __line__ "__file__" 1],[ .stabd 68,0,$1 -]) +])]) @@ -98,10 +106,20 @@ ]) +define([_emit_COFF_source_line_stab],[ + .loc 1 $1 0 +]) define([emit_source_line_stab],[ - ifelse(eval(SYSstabs),eval(BSDstabs), - [_emit_BSD_source_line_stab($1)], - [_emit_ELF_source_line_stab($1)])]) + ifelse(eval(SYSstabs), + eval(BSDstabs), + [_emit_BSD_source_line_stab($1)], + eval(SYSstabs), + eval(ELFstabs), + [_emit_ELF_source_line_stab($1)], + [_emit_COFF_source_line_stab($1)])]) + + + @@ -138,5 +156,8 @@ -define([_beginfile],[ +define([_beginfile],[ifdef([WIN64],[ + .file 1 "__file__" + .text +],[ .stabs "__pwd__",N_SO,0,0,StartTextLabel() .stabs "__file__",N_SO,0,0,StartTextLabel() @@ -148,10 +169,13 @@ StartTextLabel(): # __line__ "__file__" -]) +])]) define([_endfile],[ +ifdef([WIN64],[ +],[ .stabs "",N_SO,0,0,EndTextLabel() EndTextLabel(): # __line__ +]) ]) @@ -162,8 +186,12 @@ ]) $1: +ifdef([WIN64],[ + .def $1; .scl 2; .type 32; .endef +],[ .stabd 68,0,__line__ .stabs "$1:F1",36,0,__line__,$1 +]) .set func_start,$1 -]) +# __line__ "__file__" 1 ]) @@ -180,10 +208,14 @@ ]) + define([_endfn],[ LocalLabelPrefix[]__func_name[999]: +ifdef([WIN64],[ +],[ .stabs "",36,0,0,LocalLabelPrefix[]__func_name[999]-__func_name .line __line__ ifelse(eval(SYSstabs),eval(ELFstabs),[ .size __func_name,LocalLabelPrefix[]__func_name[999]-__func_name +]) ]) undefine([__func_name]) @@ -250,5 +282,4 @@ define([__],[emit_source_line_stab(__line__) -# __line__ $@ ]) @@ -292,4 +323,5 @@ equate_if_defined([FREEBSD]) equate_if_defined([SOLARIS]) +equate_if_defined([WIN64]) equate_if_defined([PPC64]) equate_if_defined([X8664]) Index: /branches/event-ide/ccl/lisp-kernel/memprotect.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/memprotect.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/memprotect.h (revision 8262) @@ -25,5 +25,7 @@ #endif #include +#ifndef WINDOWS #include +#endif int Index: /branches/event-ide/ccl/lisp-kernel/pmcl-kernel.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/pmcl-kernel.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/pmcl-kernel.c (revision 8262) @@ -932,5 +932,5 @@ if (_NSGetExecutablePath(exepath, (void *)&len) == 0) { p = malloc(len+1); - bcopy(exepath, p, len); + memmove(p, exepath, len); p[len]=0; return p; @@ -944,5 +944,5 @@ if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) { p = malloc(n+1); - bcopy(exepath,p,n); + memmove(p,exepath,n); p[n]=0; return p; @@ -961,5 +961,5 @@ if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) { p = malloc(n+1); - bcopy(exepath,p,n); + memmove(p,exepath,n); p[n]=0; return p; @@ -1282,10 +1282,7 @@ _exit(1); } - bcopy(old, new, 0x1000); -} -#endif - -int -os_major_version = 0; + memmove(new, old, 0x1000); +} +#endif void @@ -1299,6 +1296,4 @@ exit(1); } - sscanf(uts.release,"%d",&os_major_version); - #ifdef PPC #ifdef DARWIN @@ -1885,2 +1880,42 @@ +#ifdef DARWIN +void +sample_paging_info(paging_info *stats) +{ + mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT; + + task_info(mach_task_self(), + TASK_EVENTS_INFO, + (task_info_t)stats, + &count); +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ + fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n", + stop->cow_faults-start->cow_faults, + stop->faults-start->faults, + stop->pageins-start->pageins); +} + +#else +#ifndef WINDOWS +void +sample_paging_info(paging_info *stats) +{ + getrusage(RUSAGE_SELF, stats); +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ + fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n", + stop->ru_minflt-start->ru_minflt, + stop->ru_majflt-start->ru_majflt, + stop->ru_nswap-start->ru_nswap); +} + +#endif +#endif Index: /branches/event-ide/ccl/lisp-kernel/ppc-constants.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/ppc-constants.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/ppc-constants.h (revision 8262) @@ -68,4 +68,6 @@ #define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4) #define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) +#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) +#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) #define TCR_STATE_FOREIGN (1) Index: /branches/event-ide/ccl/lisp-kernel/ppc-constants32.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/ppc-constants32.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/ppc-constants32.s (revision 8262) @@ -607,4 +607,10 @@ TCR_FLAG_BIT_FOREIGN = fixnum_shift TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) +TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) +TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) +TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) +TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) r0 = 0 Index: /branches/event-ide/ccl/lisp-kernel/ppc-constants64.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/ppc-constants64.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/ppc-constants64.s (revision 8262) @@ -577,5 +577,11 @@ TCR_FLAG_BIT_FOREIGN = fixnum_shift -TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) +TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) +TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) +TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) +TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) Index: /branches/event-ide/ccl/lisp-kernel/ppc-exceptions.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/ppc-exceptions.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/ppc-exceptions.c (revision 8262) @@ -460,11 +460,16 @@ fatal_oserr(": save_application", err); } - if (selector == GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE) { - LispObj aligned_arg = align_to_power_of_2(arg, log2_nbits_in_word); - signed_natural - delta_dnodes = ((signed_natural) aligned_arg) - - ((signed_natural) tenured_area->static_dnodes); - change_hons_area_size_from_xp(xp, delta_dnodes*dnode_size); - xpGPR(xp, imm0) = tenured_area->static_dnodes; + switch (selector) { + case GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE: + xpGPR(xp, imm0) = 0; + break; + + case GC_TRAP_FUNCTION_FREEZE: + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + xpGPR(xp, imm0) = tenured_area->static_dnodes << dnode_shift; + break; + default: + break; } } @@ -788,9 +793,4 @@ } -int -change_hons_area_size_from_xp(ExceptionInformation *xp, signed_natural delta_in_bytes) -{ - return gc_like_from_xp(xp, change_hons_area_size, delta_in_bytes); -} @@ -1327,5 +1327,9 @@ case UUO_INTERR: - status = handle_error(xp, errnum, rb, 0, where); + if (errnum == error_propagate_suspend) { + status = 0; + } else { + status = handle_error(xp, errnum, rb, 0, where); + } break; @@ -1759,11 +1763,16 @@ old_valence = prepare_to_wait_for_exception_lock(tcr, context); } + + if (tcr->flags & (1<regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context)); - if (lisp_Debugger(context, info, signum, foreign, msg)) { + if (lisp_Debugger(context, info, signum, false, msg)) { SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); } @@ -2086,5 +2095,5 @@ sigfillset(&sa.sa_mask); sa.sa_flags = - SA_RESTART + 0 /* SA_RESTART */ | SA_SIGINFO #ifdef DARWIN @@ -2446,5 +2455,5 @@ stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN); mc = (MCONTEXT_T) ptr_from_lispobj(stackp); - bcopy(&ts,&(mc->__ss),sizeof(ts)); + memmove(&(mc->__ss),&ts,sizeof(ts)); thread_state_count = PPC_FLOAT_STATE_COUNT; Index: /branches/event-ide/ccl/lisp-kernel/ppc-gc.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/ppc-gc.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/ppc-gc.c (revision 8262) @@ -26,28 +26,4 @@ #include -void -comma_output_decimal(char *buf, int len, natural n) -{ - int nout = 0; - - buf[--len] = 0; - do { - buf[--len] = n%10+'0'; - n = n/10; - if (n == 0) { - while (len) { - buf[--len] = ' '; - } - return; - } - if (len == 0) return; - nout ++; - if (nout == 3) { - buf[--len] = ','; - nout = 0; - } - } while (len >= 0); -} - /* Heap sanity checking. */ @@ -63,5 +39,5 @@ case fulltag_odd_fixnum: -#ifdef PPC + #ifdef PPC64 case fulltag_imm_0: @@ -72,5 +48,5 @@ case fulltag_imm: #endif -#endif + return; @@ -84,5 +60,5 @@ #endif -#ifdef PPC + #ifdef PPC64 case fulltag_nodeheader_0: @@ -98,5 +74,5 @@ case fulltag_immheader: #endif -#endif + Bug(NULL, "Header not expected : 0x%lx", n); @@ -139,5 +115,4 @@ } -Boolean GCDebug = false, GCverbose = false; @@ -229,26 +204,12 @@ } -natural -static_dnodes_for_area(area *a) -{ - if (a->low == tenured_area->low) { - return tenured_area->static_dnodes; - } - return 0; -} - - - - - - - - -bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL; -LispObj GCarealow, GCareadynamiclow; -natural GCndnodes_in_area, GCndynamic_dnodes_in_area; -LispObj GCweakvll = (LispObj)NULL; -LispObj GCephemeral_low; -natural GCn_ephemeral_dnodes; + + + + + + + + @@ -292,5 +253,5 @@ tag_n = fulltag_of(header); -#ifdef PPC + #ifdef PPC64 if ((nodeheader_tag_p(tag_n)) || @@ -323,5 +284,5 @@ } #endif -#endif + @@ -342,8 +303,8 @@ ((hash_table_vector_header *) base)->cache_key = undefined; ((hash_table_vector_header *) base)->cache_value = lisp_nil; - } - deref(ptr_to_lispobj(base),1) = GCweakvll; - GCweakvll = n; - return; + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = n; + return; + } } @@ -405,5 +366,5 @@ } -#ifdef PPC + #ifdef PPC64 /* Any register (srr0, the lr or ctr) or stack location that @@ -494,7 +455,7 @@ } #endif /* PPC64 */ -#endif /* PPC */ - -#ifdef PPC + + + #ifdef PPC64 #define RMARK_PREV_ROOT fulltag_imm_3 @@ -504,9 +465,7 @@ #define RMARK_PREV_CAR fulltag_nil #endif -#endif - - -natural -GCstack_limit = 0; + + + @@ -550,5 +509,4 @@ suffix_dnodes; tag_n = fulltag_of(header); -#ifdef PPC #ifdef PPC64 if ((nodeheader_tag_p(tag_n)) || @@ -581,5 +539,5 @@ } #endif -#endif + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; @@ -605,8 +563,8 @@ ((hash_table_vector_header *) base)->cache_key = undefined; ((hash_table_vector_header *) base)->cache_value = lisp_nil; - } - deref(ptr_to_lispobj(base),1) = GCweakvll; - GCweakvll = n; - return; + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = n; + return; + } } @@ -727,5 +685,4 @@ tag_n = fulltag_of(header); -#ifdef PPC #ifdef PPC64 if ((nodeheader_tag_p(tag_n)) || @@ -758,5 +715,5 @@ } #endif -#endif + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; @@ -775,9 +732,9 @@ ((hash_table_vector_header *) base)->cache_key = undefined; ((hash_table_vector_header *) base)->cache_value = lisp_nil; - } - - deref(ptr_to_lispobj(base),1) = GCweakvll; - GCweakvll = this; - goto Climb; + + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = this; + goto Climb; + } } @@ -1033,29 +990,28 @@ ((hash_table_vector_header *) start)->cache_key = undefined; ((hash_table_vector_header *) start)->cache_value = lisp_nil; - } - - start[1] = GCweakvll; - GCweakvll = (LispObj) (((natural) start) + fulltag_misc); - } else { - - if (subtag == subtag_pool) { - start[1] = lisp_nil; - } - - if (subtag == subtag_weak) { - natural weak_type = (natural) start[2]; - if (weak_type >> population_termination_bit) - element_count -= 2; - else - element_count -= 1; - start[1] = GCweakvll; - GCweakvll = (LispObj) (((natural) start) + fulltag_misc); - } - - base = start + element_count + 1; - while(element_count--) { - mark_root(*--base); - } - } + + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + element_count = 0; + } + } + if (subtag == subtag_pool) { + start[1] = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) start[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + } + + base = start + element_count + 1; + while(element_count--) { + mark_root(*--base); + } start += size; } @@ -1113,5 +1069,5 @@ } -#ifdef PPC + /* Mark lisp frames on the control stack. @@ -1148,350 +1104,6 @@ } } -#endif - -void -reapweakv(LispObj weakv) -{ - /* - element 2 of the weak vector should be tagged as a cons: if it - isn't, just mark it as a root. if it is, cdr through it until a - "marked" cons is encountered. If the car of any unmarked cons is - marked, mark the cons which contains it; otherwise, splice the - cons out of the list. N.B. : elements 0 and 1 are already marked - (or are immediate, etc.) - */ - LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev; - LispObj termination_list = lisp_nil; - natural weak_type = (natural) deref(weakv,2); - Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist), - terminatablep = ((weak_type >> population_termination_bit) != 0); - Boolean done = false; - cons *rawcons; - natural dnode, car_dnode; - bitvector markbits = GCmarkbits; - - if (terminatablep) { - termination_list = deref(weakv,1+3); - } - - if (fulltag_of(cell) != fulltag_cons) { - mark_root(cell); - } else if (alistp) { - /* weak alist */ - while (! done) { - dnode = gc_area_dnode(cell); - if ((dnode >= GCndnodes_in_area) || - (ref_bit(markbits, dnode))) { - done = true; - } else { - /* Cons cell is unmarked. */ - LispObj alist_cell, thecar; - unsigned cell_tag; - - rawcons = (cons *) ptr_from_lispobj(untag(cell)); - alist_cell = rawcons->car; - cell_tag = fulltag_of(alist_cell); - - if ((cell_tag == fulltag_cons) && - ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) && - (! ref_bit(markbits, car_dnode)) && - (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) && - ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && - (! ref_bit(markbits, car_dnode))) { - *prev = rawcons->cdr; - if (terminatablep) { - rawcons->cdr = termination_list; - termination_list = cell; - } - } else { - set_bit(markbits, dnode); - prev = (LispObj *)(&(rawcons->cdr)); - mark_root(alist_cell); - } - cell = *prev; - } - } - } else { - /* weak list */ - while (! done) { - dnode = gc_area_dnode(cell); - if ((dnode >= GCndnodes_in_area) || - (ref_bit(markbits, dnode))) { - done = true; - } else { - /* Cons cell is unmarked. */ - LispObj thecar; - unsigned cartag; - - rawcons = (cons *) ptr_from_lispobj(untag(cell)); - thecar = rawcons->car; - cartag = fulltag_of(thecar); - - if (is_node_fulltag(cartag) && - ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && - (! ref_bit(markbits, car_dnode))) { - *prev = rawcons->cdr; - if (terminatablep) { - rawcons->cdr = termination_list; - termination_list = cell; - } - } else { - set_bit(markbits, dnode); - prev = (LispObj *)(&(rawcons->cdr)); - } - cell = *prev; - } - } - } - - if (terminatablep) { - deref(weakv,1+3) = termination_list; - if (termination_list != lisp_nil) { - deref(weakv,1) = GCweakvll; - GCweakvll = weakv; - } - } -} - -/* - Screw: doesn't deal with finalization. - */ - -void -reaphashv(LispObj hashv) -{ - hash_table_vector_header - *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv)); - natural - dnode, - npairs = (header_element_count(hashp->header) - - ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1; - LispObj *pairp = (LispObj*) (hashp+1), weakelement; - Boolean - weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); - bitvector markbits = GCmarkbits; - int tag; - - while (npairs--) { - if (weak_on_value) { - weakelement = pairp[1]; - } else { - weakelement = pairp[0]; - } - tag = fulltag_of(weakelement); - if (is_node_fulltag(tag)) { - dnode = gc_area_dnode(weakelement); - if ((dnode < GCndnodes_in_area) && - ! ref_bit(markbits, dnode)) { - pairp[0] = slot_unbound; - pairp[1] = lisp_nil; - hashp->weak_deletions_count += (1<flags, key_dnode, val_dnode; - Boolean - marked_new = false, - key_marked, - val_marked, - weak_value = ((flags & nhash_weak_value_mask) != 0); - int - skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1, - key_tag, - val_tag, - i; - LispObj - *pairp = (LispObj*) (hashp+1), - key, - val; - - /* Mark everything in the header */ - - for (i = 2; i<= skip; i++) { - mark_root(deref(ptr_to_lispobj(hashp),i)); - } - - elements -= skip; - - for (i = 0; i> population_termination_bit) { - elements -= 1; - } - for(alist = deref(weak_alist, elements); - (fulltag_of(alist) == fulltag_cons) && - ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) && - (! ref_bit(markbits,dnode)); - alist = cdr(alist)) { - pair = car(alist); - pair_tag = fulltag_of(pair); - if ((is_node_fulltag(pair_tag)) && - ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) && - (! ref_bit(markbits,dnode))) { - if (pair_tag == fulltag_cons) { - key = car(pair); - if ((! is_node_fulltag(fulltag_of(key))) || - ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) || - ref_bit(markbits,dnode)) { - /* key is marked, mark value if necessary */ - value = cdr(pair); - if (is_node_fulltag(fulltag_of(value)) && - ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) && - (! ref_bit(markbits,dnode))) { - mark_root(value); - marked_new = true; - } - } - } else { - mark_root(pair); - marked_new = true; - } - } - } - return marked_new; -} - -void -markhtabvs() -{ - LispObj this, header, pending; - int subtag; - bitvector markbits = GCmarkbits; - hash_table_vector_header *hashp; - Boolean marked_new; - - do { - pending = (LispObj) NULL; - marked_new = false; - - while (GCweakvll) { - this = GCweakvll; - GCweakvll = deref(this,1); - - header = header_of(this); - subtag = header_subtag(header); - - if (subtag == subtag_weak) { - natural weak_type = deref(this,2); - deref(this,1) = pending; - pending = this; - if ((weak_type & population_type_mask) == population_weak_alist) { - if (mark_weak_alist(this, weak_type)) { - marked_new = true; - } - } - } else if (subtag == subtag_hash_vector) { - natural elements = header_element_count(header), i; - - hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this)); - if (hashp->flags & nhash_weak_mask) { - deref(this,1) = pending; - pending = this; - if (mark_weak_hash_vector(hashp, elements)) { - marked_new = true; - } - } else { - deref(this,1) = (LispObj)NULL; - for (i = 2; i <= elements; i++) { - mark_root(deref(this,i)); - } - } - } else { - Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this); - } - } - - if (marked_new) { - GCweakvll = pending; - } - } while (marked_new); - - /* Now, everything's marked that's going to be, and "pending" is a list - of populations and weak hash tables. CDR down that list and free - anything that isn't marked. - */ - - while (pending) { - this = pending; - pending = deref(this,1); - deref(this,1) = (LispObj)NULL; - - subtag = header_subtag(header_of(this)); - if (subtag == subtag_weak) { - reapweakv(this); - } else { - reaphashv(this); - } - } - - /* Finally, mark the termination lists in all terminatable weak vectors - They are now linked together on GCweakvll. - This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, - but it will force terminatable popualations to hold on to each other - (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). - */ - pending = GCweakvll; - GCweakvll = (LispObj)NULL; - while (pending) { - this = pending; - pending = deref(this,1); - deref(this,1) = (LispObj)NULL; - mark_root(deref(this,1+3)); - } -} + + /* Mark the lisp objects in an exception frame */ @@ -1526,176 +1138,4 @@ } -void -mark_tcr_tlb(TCR *tcr) -{ - natural n = tcr->tlb_limit; - LispObj - *start = tcr->tlb_pointer, - *end = (LispObj *) ((BytePtr)start+n), - node; - - while (start < end) { - node = *start; - if (node != no_thread_local_binding_marker) { - mark_root(node); - } - start++; - } -} - -/* - Mark things that're only reachable through some (suspended) TCR. - (This basically means the tcr's gc_context and the exception - frames on its xframe_list.) -*/ - -void -mark_tcr_xframes(TCR *tcr) -{ - xframe_list *xframes; - ExceptionInformation *xp; - - xp = tcr->gc_context; - if (xp) { - mark_xp(xp); - } - - for (xframes = (xframe_list *) tcr->xframe; - xframes; - xframes = xframes->prev) { - mark_xp(xframes->curr); - } -} - - -void *postGCptrs = NULL; - -void -postGCfree(void *p) -{ - *(void **)p = postGCptrs; - postGCptrs = p; -} - -void -freeGCptrs() -{ - void *p, *next; - - for (p = postGCptrs; p; p = next) { - next = *((void **)p); - free(p); - } - postGCptrs = NULL; -} - -void -reap_gcable_ptrs() -{ - LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr; - xmacptr_flag flag; - natural dnode; - xmacptr *x; - - while((next = *prev) != (LispObj)NULL) { - dnode = gc_area_dnode(next); - x = (xmacptr *) ptr_from_lispobj(untag(next)); - - if ((dnode >= GCndnodes_in_area) || - (ref_bit(GCmarkbits,dnode))) { - prev = &(x->link); - } else { - *prev = x->link; - flag = (xmacptr_flag)(x->flags); - ptr = x->address; - - if (ptr) { - switch (flag) { - case xmacptr_flag_recursive_lock: - destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr)); - break; - - case xmacptr_flag_ptr: - postGCfree((void *)ptr_from_lispobj(ptr)); - break; - - case xmacptr_flag_rwlock: - break; - - case xmacptr_flag_semaphore: - destroy_semaphore((void**)&(x->address)); - break; - - default: - /* (warn "unknown xmacptr_flag: ~s" flag) */ - /* Unknowd, and perhaps unknowdable. */ - /* Fall in: */ - case xmacptr_flag_none: - break; - } - } - } - } -} - - - -#if WORD_SIZE == 64 -unsigned short *_one_bits = NULL; - -unsigned short -logcount16(unsigned short n) -{ - unsigned short c=0; - - while(n) { - n = n & (n-1); - c++; - } - return c; -} - -void -gc_init() -{ - int i; - - _one_bits = malloc(sizeof(unsigned short) * (1<<16)); - - for (i = 0; i < (1<<16); i++) { - _one_bits[i] = dnode_size*logcount16(i); - } -} - -#define one_bits(x) _one_bits[x] - -#else -const unsigned char _one_bits[256] = { - 0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8 -}; - -#define one_bits(x) _one_bits[x] - -void -gc_init() -{ -} - -#endif /* A "pagelet" contains 32 doublewords. The relocation table contains @@ -1873,59 +1313,6 @@ } -LispObj -node_forwarding_address(LispObj node) -{ - int tag_n; - natural dnode = gc_dynamic_area_dnode(node); - - if ((dnode >= GCndynamic_dnodes_in_area) || - (node < GCfirstunmarked)) { - return node; - } - - tag_n = fulltag_of(node); - if (!is_node_fulltag(tag_n)) { - return node; - } - - return dnode_forwarding_address(dnode, tag_n); -} - -Boolean -update_noderef(LispObj *noderef) -{ - LispObj - node = *noderef, - new = node_forwarding_address(node); - - if (new != node) { - *noderef = new; - return true; - } - return false; -} - -void -update_locref(LispObj *locref) -{ - LispObj - obj = *locref, - new = locative_forwarding_address(obj); - - if (new != obj) { - *locref = new; - } -} - -void -forward_gcable_ptrs() -{ - LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; - - while ((next = *prev) != (LispObj)NULL) { - *prev = node_forwarding_address(next); - prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); - } -} + + void @@ -1990,79 +1377,4 @@ -void -forward_memoized_area(area *a, natural num_memo_dnodes) -{ - bitvector refbits = a->refbits; - LispObj *p = (LispObj *) a->low, x1, x2, new; - natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0; - int tag_x1; - hash_table_vector_header *hashp = NULL; - Boolean header_p; - - if (GCDebug) { - check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); - } - - /* This is pretty straightforward, but we have to note - when we move a key in a hash table vector that wants - us to tell it about that. */ - - set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); - while (memo_dnode < num_memo_dnodes) { - if (bits == 0) { - int remain = nbits_in_word - bitidx; - memo_dnode += remain; - p += (remain+remain); - bits = *++bitsp; - bitidx = 0; - } else { - nextbit = count_leading_zeros(bits); - if ((diff = (nextbit - bitidx)) != 0) { - memo_dnode += diff; - bitidx = nextbit; - p += (diff+diff); - } - x1 = p[0]; - x2 = p[1]; - tag_x1 = fulltag_of(x1); - bits &= ~(BIT0_MASK >> bitidx); - header_p = (nodeheader_tag_p(tag_x1)); - - if (header_p && - (header_subtag(x1) == subtag_hash_vector)) { - hashp = (hash_table_vector_header *) p; - if (hashp->flags & nhash_track_keys_mask) { - hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1); - } else { - hashp = NULL; - } - } - - - if (! header_p) { - new = node_forwarding_address(x1); - if (new != x1) { - *p = new; - } - } - p++; - - new = node_forwarding_address(x2); - if (new != x2) { - *p = new; - if (memo_dnode < hash_dnode_limit) { - hashp->flags |= nhash_key_moved_mask; - hash_dnode_limit = 0; - hashp = NULL; - } - } - p++; - memo_dnode++; - bitidx++; - - } - } -} - @@ -2107,5 +1419,4 @@ } -#ifdef PPC void forward_cstack_area(area *a) @@ -2129,5 +1440,5 @@ } -#endif + void @@ -2136,5 +1447,4 @@ natural *regs = (natural *) xpGPRvector(xp); -#ifdef PPC int r; @@ -2152,25 +1462,7 @@ update_locref((LispObj*) (&(xpLR(xp)))); update_locref((LispObj*) (&(xpCTR(xp)))); -#endif - -} - -void -forward_tcr_tlb(TCR *tcr) -{ - natural n = tcr->tlb_limit; - LispObj - *start = tcr->tlb_pointer, - *end = (LispObj *) ((BytePtr)start+n), - node; - - while (start < end) { - node = *start; - if (node != no_thread_local_binding_marker) { - update_noderef(start); - } - start++; - } -} + +} + void @@ -2192,51 +1484,4 @@ } -void -forward_and_resolve_static_references(area *a) -{ - natural - nstatic = static_dnodes_for_area(a), - nstatic_bitmap_words = nstatic >> bitmap_shift; - if (nstatic != 0) { - /* exploit the fact that a cons is the same size as a dnode. */ - cons *pagelet_start = (cons *) a->low, *work; - bitvector markbits = GCmarkbits, - usedbits = tenured_area->static_used; - natural marked, used, used_but_not_marked, ndeleted = 0, i; - - while (nstatic_bitmap_words--) { - marked = *markbits++; - used = *usedbits; - if (marked != used) { - *usedbits = marked; - } - used |= marked; - used_but_not_marked = used & ~marked; - - while (marked) { - i = count_leading_zeros(marked); - marked &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - update_noderef(&work->cdr); - update_noderef(&work->car); - } - - while (used_but_not_marked) { - i = count_leading_zeros(used_but_not_marked); - used_but_not_marked &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - if ((work->cdr != undefined) && - (work->cdr != slot_unbound)) { - work->car = slot_unbound; - work->cdr = slot_unbound; - ndeleted++; - } - } - usedbits++; - pagelet_start += nbits_in_word; - } - lisp_global(DELETED_STATIC_PAIRS) += box_fixnum(ndeleted); - } -} @@ -2417,445 +1662,15 @@ -Boolean -youngest_non_null_area_p (area *a) -{ - if (a->active == a->high) { - return false; - } else { - for (a = a->younger; a; a = a->younger) { - if (a->active != a->high) { - return false; - } - } - }; - return true; -} - -Boolean just_purified_p = false; - - -/* - All thread's stack areas have been "normalized", as - has the dynamic heap. (The "active" pointer in these areas - matches the stack pointer/freeptr value at the time that - the exception occurred.) -*/ - - -#define get_time(when) gettimeofday(&when, NULL) - -#define MARK_RECURSIVELY_USING_STACK 1 -#if !MARK_RECURSIVELY_USING_STACK -#warning recursive marker disabled for testing; remember to re-enable it -#endif - -void -gc(TCR *tcr, signed_natural param) -{ - xframe_list *xframes = (tcr->xframe); - struct timeval start, stop; - area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; - unsigned timeidx = 1; - xframe_list *x; - LispObj - pkg, - itabvec = 0; - BytePtr oldfree = a->active; - TCR *other_tcr; - natural static_dnodes; - -#if MARK_RECURSIVELY_USING_STACK - if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { - GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; - } else { - GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size; - } -#else - GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; -#endif - - GCephemeral_low = lisp_global(OLDEST_EPHEMERAL); - if (GCephemeral_low) { - GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low); - } else { - GCn_ephemeral_dnodes = 0; - } - - if (GCn_ephemeral_dnodes) { - GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0); - } else { - GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0); - } - - if (GCephemeral_low) { - if ((oldfree-g1_area->low) < g1_area->threshold) { - to = g1_area; - note = a; - timeidx = 4; - } else if ((oldfree-g2_area->low) < g2_area->threshold) { - to = g2_area; - from = g1_area; - note = g1_area; - timeidx = 3; - } else { - to = tenured_area; - from = g2_area; - note = g2_area; - timeidx = 2; - } - } else { - note = tenured_area; - } - - if (GCverbose) { - char buf[16]; - - comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift); - if (GCephemeral_low) { - fprintf(stderr, - "\n\n;;; Starting EGC of generation %d", - (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); - } else { - fprintf(stderr,"\n\n;;; Starting full GC"); - } - fprintf(stderr, ", %s bytes allocated.\n", buf); - } - - get_time(start); - lisp_global(IN_GC) = (1<markbits; - GCarealow = ptr_to_lispobj(a->low); -#ifdef DEBUG - fprintf(stderr, "GC: low = #x%x, high = #x%x\n",a->low,oldfree); -#endif - GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift); - GCndnodes_in_area = gc_area_dnode(oldfree); - - - if (GCndnodes_in_area) { - GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes; - GCdynamic_markbits = - GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift); - - zero_bits(GCmarkbits, GCndnodes_in_area); - GCweakvll = (LispObj)NULL; - - - if (GCn_ephemeral_dnodes == 0) { - /* For GCTWA, mark the internal package hash table vector of - *PACKAGE*, but don't mark its contents. */ - { - LispObj - itab; - natural - dnode, ndnodes; - - pkg = nrs_PACKAGE.vcell; - if ((fulltag_of(pkg) == fulltag_misc) && - (header_subtag(header_of(pkg)) == subtag_package)) { - itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab; - itabvec = car(itab); - dnode = gc_area_dnode(itabvec); - if (dnode < GCndnodes_in_area) { - ndnodes = (header_element_count(header_of(itabvec))+1) >> 1; - set_n_bits(GCmarkbits, dnode, ndnodes); - } - } - } - } - - { - area *next_area; - area_code code; - - /* Could make a jump table instead of the typecase */ - - for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - mark_tstack_area(next_area); - break; - - case AREA_VSTACK: - mark_vstack_area(next_area); - break; - - case AREA_CSTACK: -#ifdef PPC - mark_cstack_area(next_area); -#endif - break; - - case AREA_STATIC: - case AREA_DYNAMIC: /* some heap that isn't "the" heap */ - /* In both of these cases, we -could- use the area's "markbits" - bitvector as a reference map. It's safe (but slower) to - ignore that map and process the entire area. - */ - if (next_area->younger == NULL) { - mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active); - } - break; - - default: - break; - } - } - } - - if (lisp_global(OLDEST_EPHEMERAL)) { - mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low)); - } - - other_tcr = tcr; - do { - mark_tcr_xframes(other_tcr); - mark_tcr_tlb(other_tcr); - other_tcr = other_tcr->next; - } while (other_tcr != tcr); - - - - - /* Go back through *package*'s internal symbols, marking - any that aren't worthless. - */ - - if (itabvec) { - natural - i, - n = header_element_count(header_of(itabvec)); - LispObj - sym, - *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); - - for (i = 0; i < n; i++) { - sym = *raw++; - if (fulltag_of(sym) == fulltag_misc) { - lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); - natural dnode = gc_area_dnode(sym); - - if ((dnode < GCndnodes_in_area) && - (!ref_bit(GCmarkbits,dnode))) { - /* Symbol is in GC area, not marked. - Mark it if fboundp, boundp, or if - it has a plist or another home package. - */ - - if (FBOUNDP(rawsym) || - BOUNDP(rawsym) || - (rawsym->flags != 0) || /* SPECIAL, etc. */ - (rawsym->plist != lisp_nil) || - ((rawsym->package_predicate != pkg) && - (rawsym->package_predicate != lisp_nil))) { - mark_root(sym); - } - } - } - } - } - - (void)markhtabvs(); - - if (itabvec) { - natural - i, - n = header_element_count(header_of(itabvec)); - LispObj - sym, - *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); - - for (i = 0; i < n; i++, raw++) { - sym = *raw; - if (fulltag_of(sym) == fulltag_misc) { - lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); - natural dnode = gc_area_dnode(sym); - - if ((dnode < GCndnodes_in_area) && - (!ref_bit(GCmarkbits,dnode))) { - *raw = unbound_marker; - } - } - } - } - - reap_gcable_ptrs(); - - GCrelocptr = global_reloctab; - GCfirstunmarked = calculate_relocation(); - - forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked)); - - other_tcr = tcr; - do { - forward_tcr_xframes(other_tcr); - forward_tcr_tlb(other_tcr); - other_tcr = other_tcr->next; - } while (other_tcr != tcr); - - - forward_gcable_ptrs(); - - - - { - area *next_area; - area_code code; - - /* Could make a jump table instead of the typecase */ - - for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - forward_tstack_area(next_area); - break; - - case AREA_VSTACK: - forward_vstack_area(next_area); - break; - - case AREA_CSTACK: -#ifdef PPC - forward_cstack_area(next_area); -#endif - break; - - case AREA_STATIC: - case AREA_DYNAMIC: /* some heap that isn't "the" heap */ - if (next_area->younger == NULL) { - forward_range((LispObj *) next_area->low, (LispObj *) next_area->active); - } - break; - - default: - break; - } - } - } - - if (GCephemeral_low) { - forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); - } else { - /* Full GC, need to process static space */ - forward_and_resolve_static_references(a); - } - - a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap()); -#ifdef DEBUG - fprintf(stderr, "GC done, new active ptr = #x%x\n",a->active); -#endif - - if (to) { - tenure_to_area(to); - } - - zero_memory_range(a->active, oldfree); - - resize_dynamic_heap(a->active, - (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0); - - /* - If the EGC is enabled: If there's no room for the youngest - generation, untenure everything. If this was a full GC and - there's now room for the youngest generation, tenure everything. - */ - if (a->older != NULL) { - natural nfree = (a->high - a->active); - - - if (nfree < a->threshold) { - untenure_from_area(tenured_area); - } else { - if (GCephemeral_low == 0) { - tenure_to_area(tenured_area); - } - } - } - } - lisp_global(GC_NUM) += (1<gccount += (1<vcell; - if ((fulltag_of(val) == fulltag_misc) && - (header_subtag(header_of(val)) == subtag_macptr)) { - timersub(&stop, &start, &elapsed); - timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address); - timeradd(timeinfo, &elapsed, timeinfo); - timeradd(timeinfo+timeidx, &elapsed, timeinfo+timeidx); - } - - val = total_bytes_freed->vcell; - if ((fulltag_of(val) == fulltag_misc) && - (header_subtag(header_of(val)) == subtag_macptr)) { - long long justfreed = oldfree - a->active; - *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed; - if (GCverbose) { - char buf[16]; - if (justfreed <= heap_segment_size) { - justfreed = 0; - } - if (note == tenured_area) { - fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec); - } else { - fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", - (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, - buf, - elapsed.tv_sec, elapsed.tv_usec); - } - } - } - } -#ifdef DEBUG - fprintf(stderr, "Finished GC of %s\n", - (note == tenured_area) ? - "tenured area" : - ((from == g2_area) ? "generation 2" : - ((from == g1_area) ? "generation 1" : "generation 0"))); -#endif -} + - /* - Total the (physical) byte sizes of all ivectors in the indicated memory range - */ - - natural - unboxed_bytes_in_range(LispObj *start, LispObj *end) - { +/* + Total the (physical) byte sizes of all ivectors in the indicated memory range +*/ + +natural +unboxed_bytes_in_range(LispObj *start, LispObj *end) +{ natural total=0, elements, tag, subtag, bytes; LispObj header; @@ -2873,5 +1688,4 @@ subtag = header_subtag(header); -#ifdef PPC #ifdef PPC64 switch(fulltag_of(header)) { @@ -2906,5 +1720,5 @@ } #endif -#endif + bytes = (bytes+dnode_size-1) & ~(dnode_size-1); @@ -3566,5 +2380,5 @@ } a->active += n; - bcopy(ro_base, oldfree, n); + memmove(oldfree, ro_base, n); munmap(ro_base, n); a->ndnodes = area_dnode(a, a->active); @@ -3587,700 +2401,2 @@ } - -void -adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta) -{ - LispObj p = *loc; - - if (area_dnode(p, base) < limit) { - *loc = p+delta; - } -} - -/* like adjust_locref() above, but only changes the contents of LOC if it's - a tagged lisp pointer */ -void -adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta) -{ - LispObj p = *loc; - int tag_n = fulltag_of(p); - - if (is_node_fulltag(tag_n)) { - if (area_dnode(p, base) < limit) { - *loc = p+delta; - } - } -} - -/* - If *loc is a tagged pointer into the address range denoted by BASE and LIMIT, - nuke it (set it to NIL.) -*/ -void -nuke_noderef(LispObj *loc, LispObj base, LispObj limit) -{ - LispObj p = *loc; - int tag_n = fulltag_of(p); - - if (is_node_fulltag(tag_n)) { - if (area_dnode(p, base) < limit) { - *loc = lisp_nil; - } - } -} - - -void -adjust_pointers_in_xp(ExceptionInformation *xp, - LispObj base, - LispObj limit, - signed_natural delta) -{ - natural *regs = (natural *) xpGPRvector(xp); -#ifdef PPC - int r; - for (r = fn; r < 32; r++) { - adjust_noderef((LispObj *) (&(regs[r])), - base, - limit, - delta); - } - adjust_locref((LispObj*) (&(regs[loc_pc])), base, limit, delta); - adjust_locref((LispObj*) (&(xpPC(xp))), base, limit, delta); - adjust_locref((LispObj*) (&(xpLR(xp))), base, limit, delta); - adjust_locref((LispObj*) (&(xpCTR(xp))), base, limit, delta); -#endif - -} - -void -nuke_pointers_in_xp(ExceptionInformation *xp, - LispObj base, - LispObj limit) -{ - natural *regs = (natural *) xpGPRvector(xp); -#ifdef PPC - int r; - for (r = fn; r < 32; r++) { - nuke_noderef((LispObj *) (&(regs[r])), - base, - limit); - } -#endif - -} - -void -adjust_pointers_in_range(LispObj *range_start, - LispObj *range_end, - LispObj base, - LispObj limit, - signed_natural delta) -{ - LispObj *p = range_start, node, new; - int tag_n; - natural nwords; - hash_table_vector_header *hashp; - - while (p < range_end) { - node = *p; - tag_n = fulltag_of(node); - if (immheader_tag_p(tag_n)) { - p = (LispObj *) skip_over_ivector((natural) p, node); - } else if (nodeheader_tag_p(tag_n)) { - nwords = header_element_count(node); - nwords += (1 - (nwords&1)); - if ((header_subtag(node) == subtag_hash_vector) && - ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { - hashp = (hash_table_vector_header *) p; - hashp->flags |= nhash_key_moved_mask; - } - p++; - while (nwords--) { - adjust_noderef(p, base, limit, delta); - p++; - } - } else { - /* just a cons */ - adjust_noderef(p, base, limit, delta); - p++; - adjust_noderef(p, base, limit, delta); - p++; - } - } -} - -void -nuke_pointers_in_range(LispObj *range_start, - LispObj *range_end, - LispObj base, - LispObj limit) -{ - LispObj *p = range_start, node, new; - int tag_n; - natural nwords; - - while (p < range_end) { - node = *p; - tag_n = fulltag_of(node); - if (immheader_tag_p(tag_n)) { - p = (LispObj *) skip_over_ivector((natural) p, node); - } else if (nodeheader_tag_p(tag_n)) { - nwords = header_element_count(node); - nwords += (1 - (nwords&1)); - p++; - while (nwords--) { - nuke_noderef(p, base, limit); - p++; - } - } else { - /* just a cons */ - nuke_noderef(p, base, limit); - p++; - nuke_noderef(p, base, limit); - p++; - } - } -} - -void -adjust_pointers_in_tstack_area(area *a, - LispObj base, - LispObj limit, - LispObj delta) -{ - LispObj - *current, - *next, - *start = (LispObj *) a->active, - *end = start, - *area_limit = (LispObj *) (a->high); - - for (current = start; - end != area_limit; - current = next) { - next = ptr_from_lispobj(*current); - end = ((next >= start) && (next < area_limit)) ? next : area_limit; - if (current[1] == 0) { - adjust_pointers_in_range(current+2, end, base, limit, delta); - } - } -} - -void -nuke_pointers_in_tstack_area(area *a, - LispObj base, - LispObj limit) -{ - LispObj - *current, - *next, - *start = (LispObj *) a->active, - *end = start, - *area_limit = (LispObj *) (a->high); - - for (current = start; - end != area_limit; - current = next) { - next = ptr_from_lispobj(*current); - end = ((next >= start) && (next < area_limit)) ? next : area_limit; - if (current[1] == 0) { - nuke_pointers_in_range(current+2, end, base, limit); - } - } -} - -void -adjust_pointers_in_vstack_area(area *a, - LispObj base, - LispObj limit, - LispObj delta) -{ - LispObj - *p = (LispObj *) a->active, - *q = (LispObj *) a->high; - - if (((natural)p) & sizeof(natural)) { - adjust_noderef(p, base, limit, delta); - p++; - } - adjust_pointers_in_range(p, q, base, limit, delta); -} - -void -nuke_pointers_in_vstack_area(area *a, - LispObj base, - LispObj limit) -{ - LispObj - *p = (LispObj *) a->active, - *q = (LispObj *) a->high; - - if (((natural)p) & sizeof(natural)) { - nuke_noderef(p, base, limit); - p++; - } - nuke_pointers_in_range(p, q, base, limit); -} - -#ifdef PPC -void -adjust_pointers_in_cstack_area(area *a, - LispObj base, - LispObj limit, - LispObj delta) -{ - BytePtr - current, - next, - area_limit = a->high, - low = a->low; - - for (current = a->active; (current >= low) && (current < area_limit); current = next) { - next = *((BytePtr *)current); - if (next == NULL) break; - if (((next - current) == sizeof(lisp_frame)) && - (((((lisp_frame *)current)->savefn) == 0) || - (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { - adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta); - adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta); - } - } -} -#endif - - - -void -adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta) -{ - TCR *tcr = current; - xframe_list *xframes; - LispObj *tlb_start, *tlb_end; - ExceptionInformation *xp; - - do { - xp = tcr->gc_context; - if (xp) { - adjust_pointers_in_xp(xp, base, limit, delta); - } - for (xframes = (xframe_list *) tcr->xframe; - xframes; - xframes = xframes->prev) { - adjust_pointers_in_xp(xframes->curr, base, limit, delta); - } - adjust_pointers_in_range(tcr->tlb_pointer, - (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit), - base, - limit, - delta); - tcr = tcr->next; - } while (tcr != current); -} - -void -nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit) -{ - TCR *tcr = current; - xframe_list *xframes; - LispObj *tlb_start, *tlb_end; - ExceptionInformation *xp; - - do { - xp = tcr->gc_context; - if (xp) { - nuke_pointers_in_xp(xp, base, limit); - } - for (xframes = (xframe_list *) tcr->xframe; - xframes; - xframes = xframes->prev) { - nuke_pointers_in_xp(xframes->curr, base, limit); - } - nuke_pointers_in_range(tcr->tlb_pointer, - (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit), - base, - limit); - tcr = tcr->next; - } while (tcr != current); -} - -void -adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta) -{ - /* These need to be special-cased, because xmacptrs are immediate - objects that contain (in their "link" fields") tagged pointers - to other xmacptrs */ - LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; - - while ((next = *prev) != (LispObj)NULL) { - adjust_noderef(prev, base, limit, delta); - if (delta < 0) { - /* Assume that we've already moved things */ - next = *prev; - } - prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); - } -} - - -void -adjust_pointers_in_dynamic_area(area *a, - LispObj base, - LispObj limit, - signed_natural delta) -{ - natural - nstatic = static_dnodes_for_area(a), - nstatic_bitmap_words = nstatic >> bitmap_shift; - LispObj - *low = (LispObj *) (a->low), - *active = (LispObj *) (a->active), - *dynamic_low = low + (2 * nstatic); - - adjust_pointers_in_range(dynamic_low, active, base, limit, delta); - - if (nstatic && (nstatic <= a->ndnodes)) { - cons *pagelet_start = (cons *) a->low, *work; - bitvector usedbits = tenured_area->static_used; - natural used, i; - - while (nstatic_bitmap_words--) { - used = *usedbits++; - - while (used) { - i = count_leading_zeros(used); - used &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - adjust_noderef(&(work->cdr), base, limit, delta); - adjust_noderef(&(work->car), base, limit, delta); - } - pagelet_start += nbits_in_word; - } - } -} - -void -nuke_pointers_in_dynamic_area(area *a, - LispObj base, - LispObj limit) -{ - natural - nstatic = static_dnodes_for_area(a), - nstatic_bitmap_words = nstatic >> bitmap_shift; - LispObj - *low = (LispObj *) (a->low), - *active = (LispObj *) (a->active), - *dynamic_low = low + (2 * nstatic); - - nuke_pointers_in_range(dynamic_low, active, base, limit); - - if (nstatic && (nstatic <= a->ndnodes)) { - cons *pagelet_start = (cons *) a->low, *work; - bitvector usedbits = tenured_area->static_used; - natural used, i; - - while (nstatic_bitmap_words--) { - used = *usedbits++; - - while (used) { - i = count_leading_zeros(used); - used &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - nuke_noderef(&(work->cdr), base, limit); - nuke_noderef(&(work->car), base, limit); - } - pagelet_start += nbits_in_word; - } - } -} - - -void -adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta) -{ - area *next_area; - area_code code; - - for (next_area = active_dynamic_area; - (code = next_area->code) != AREA_VOID; - next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - adjust_pointers_in_tstack_area(next_area, base, limit, delta); - break; - - case AREA_VSTACK: - adjust_pointers_in_vstack_area(next_area, base, limit, delta); - break; - - case AREA_CSTACK: - adjust_pointers_in_cstack_area(next_area, base, limit, delta); - break; - - case AREA_STATIC: - case AREA_MANAGED_STATIC: - adjust_pointers_in_range((LispObj *) (next_area->low), - (LispObj *) (next_area->active), - base, - limit, - delta); - break; - - case AREA_DYNAMIC: - adjust_pointers_in_dynamic_area(next_area, base, limit, delta); - break; - } - } - adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta); - adjust_gcable_ptrs(base, limit, delta); -} - -void -nuke_all_pointers(LispObj base, LispObj limit) -{ - area *next_area; - area_code code; - - for (next_area = active_dynamic_area; - (code = next_area->code) != AREA_VOID; - next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - nuke_pointers_in_tstack_area(next_area, base, limit); - break; - - case AREA_VSTACK: - nuke_pointers_in_vstack_area(next_area, base, limit); - break; - - case AREA_CSTACK: - /* There aren't any "nukable" pointers in a cstack area */ - break; - - case AREA_STATIC: - case AREA_MANAGED_STATIC: - nuke_pointers_in_range((LispObj *) (next_area->low), - (LispObj *) (next_area->active), - base, - limit); - break; - - case AREA_DYNAMIC: - nuke_pointers_in_dynamic_area(next_area, base, limit); - break; - } - } - nuke_pointers_in_tcrs(get_tcr(false), base, limit); -} - -#ifndef MREMAP_MAYMOVE -#define MREMAP_MAYMOVE 1 -#endif - -#ifdef FREEBSD -void * -freebsd_mremap(void *old_address, - size_t old_size, - size_t new_size, - unsigned long flags) -{ - return old_address; -} -#define mremap freebsd_mremap - -#endif - -#ifdef DARWIN -void * -darwin_mremap(void *old_address, - size_t old_size, - size_t new_size, - unsigned long flags) -{ - void *end = (void *) ((char *)old_address+old_size); - - if (old_size == new_size) { - return old_address; - } - if (new_size < old_size) { - munmap(end, old_size-new_size); - return old_address; - } - { - void * new_address = mmap(NULL, - new_size, - PROT_READ|PROT_WRITE, - MAP_PRIVATE | MAP_ANON, - -1, - 0); - if (new_address != MAP_FAILED) { - vm_copy(mach_task_self(), - (vm_address_t)old_address, - old_size, - (vm_address_t)new_address); - munmap(old_address, old_size); - } - return new_address; - } -} - -#define mremap darwin_mremap -#endif - -Boolean -resize_used_bitvector(natural new_dnodes, bitvector *newbits) -{ - natural - old_dnodes = tenured_area->static_dnodes, - old_page_aligned_size = - (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3), - log2_page_size)), - new_page_aligned_size = - (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3), - log2_page_size)); - bitvector old_used = tenured_area->static_used, new_used = NULL; - - if (old_page_aligned_size == new_page_aligned_size) { - *newbits = old_used; - return true; - } - - if (old_used == NULL) { - new_used = mmap(NULL, - new_page_aligned_size, - PROT_READ|PROT_WRITE, - MAP_PRIVATE | MAP_ANON, - -1, - 0); - if (new_used == MAP_FAILED) { - *newbits = NULL; - return false; - } else { - *newbits = new_used; - return true; - } - } - if (new_page_aligned_size == 0) { - munmap(old_used, old_page_aligned_size); - *newbits = NULL; - return true; - } - - /* Have to try to remap the old bitmap. That's implementation-dependent, - and (naturally) Mach sucks, but no one understands how. - */ - new_used = mremap(old_used, - old_page_aligned_size, - new_page_aligned_size, - MREMAP_MAYMOVE); - if (new_used == MAP_FAILED) { - *newbits = NULL; - return false; - } - *newbits = new_used; - return true; -} - - -int -grow_hons_area(signed_natural delta_in_bytes) -{ - bitvector new_used; - area *ada = active_dynamic_area; - natural - delta_in_dnodes = delta_in_bytes >> dnode_shift, - current_static_dnodes = tenured_area->static_dnodes, - new_static_dnodes; - - delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word); - new_static_dnodes = current_static_dnodes+delta_in_dnodes; - delta_in_bytes = delta_in_dnodes << dnode_shift; - if (grow_dynamic_area((natural) delta_in_bytes)) { - LispObj - base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)), - oldactive = (LispObj) ada->active, - limit = area_dnode(oldactive, base); - if (!resize_used_bitvector(new_static_dnodes, &new_used)) { - shrink_dynamic_area(delta_in_bytes); - return -1; - } - tenured_area->static_used = new_used; - adjust_all_pointers(base, limit, delta_in_bytes); - memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base); - ada->ndnodes = area_dnode(ada->high, ada->low); - ada->active += delta_in_bytes; - { - LispObj *p; - natural i; - for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0; - i< delta_in_dnodes; - i++ ) { - *p++ = undefined; - *p++ = undefined; - } - tenured_area->static_dnodes += delta_in_dnodes; - xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<active-(tenured_area->low+(tenured_area->static_dnodes<> dnode_shift; - natural - current_static_dnodes = tenured_area->static_dnodes, - new_static_dnodes; - LispObj base, limit, oldactive; - bitvector newbits; - - - delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word); - new_static_dnodes = current_static_dnodes+delta_in_dnodes; - delta_in_bytes = delta_in_dnodes << dnode_shift; - oldactive = (LispObj) (ada->active); - - resize_used_bitvector(new_static_dnodes, &newbits); - tenured_area->static_used = newbits; /* redundant */ - - memmove(ada->low+(new_static_dnodes << dnode_shift), - ada->low+(current_static_dnodes << dnode_shift), - oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift))); - tenured_area->static_dnodes = new_static_dnodes; - ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */ - shrink_dynamic_area(-delta_in_bytes); - - base = (LispObj) (tenured_area->low + - (new_static_dnodes << dnode_shift)); - limit = area_dnode(tenured_area->low + - (current_static_dnodes << dnode_shift), base); - nuke_all_pointers(base, limit); - - base = (LispObj) (tenured_area->low + - (current_static_dnodes << dnode_shift)); - limit = area_dnode(oldactive, base); - adjust_all_pointers(base, limit, delta_in_bytes); - - xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<active-(tenured_area->low+(tenured_area->static_dnodes< 0) { - return grow_hons_area(delta_in_bytes); - } - if (delta_in_bytes < 0) { - return shrink_hons_area(delta_in_bytes); - } - return 0; -} - Index: /branches/event-ide/ccl/lisp-kernel/ppc-macros.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/ppc-macros.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/ppc-macros.s (revision 8262) @@ -41,231 +41,121 @@ ifdef([PPC64],[ - define([clrrri],[ - clrrdi $@ - ]) - define([clrlri],[ - clrldi $@ - ]) - define([clrlri_],[ - clrldi. $@ - ]) - define([ldr],[ - ld $@ - ]) - define([ldrx],[ - ldx $@ - ]) - define([ldru],[ - ldu $@ - ]) - define([str],[ - std $@ - ]) - define([strx],[ - stdx $@ - ]) - define([stru],[ - stdu $@ - ]) - define([strux],[ - stdux $@ - ]) - define([cmpr],[ - cmpd $@ - ]) - define([cmpri],[ - cmpdi $@ - ]) - define([cmplr],[ - cmpld $@ - ]) - define([cmplri],[ - cmpldi $@ - ]) - define([trlge],[ - tdlge $@ - ]) - define([trllt],[ - tdllt $@ - ]) - define([trlt],[ - tdlt $@ - ]) - define([trlle],[ - tdlle $@ - ]) - define([treqi],[ - tdeqi $@ - ]) - define([trnei],[ - tdnei $@ - ]) - define([trgti],[ - tdgti $@ - ]) - define([srari],[ - sradi $@ - ]) - define([srri],[ - srdi $@ - ]) - define([srr],[ - srd $@ - ]) - define([slri],[ - sldi $@ - ]) - define([lrarx],[ - ldarx $@ - ]) - define([strcx],[ - stdcx. $@ - ]) + define([clrrri],[clrrdi $@]) + define([clrlri],[clrldi $@]) + define([clrlri_],[clrldi. $@]) + define([ldr],[ld $@]) + define([ldrx],[ldx $@]) + define([ldru],[ldu $@]) + define([str],[std $@]) + define([strx],[stdx $@]) + define([stru],[stdu $@]) + define([strux],[stdux $@]) + define([cmpr],[cmpd $@]) + define([cmpri],[cmpdi $@]) + define([cmplr],[cmpld $@]) + define([cmplri],[cmpldi $@]) + define([trlge],[tdlge $@]) + define([trllt],[tdllt $@]) + define([trlt],[tdlt $@]) + define([trlle],[tdlle $@]) + define([treqi],[tdeqi $@]) + define([trnei],[tdnei $@]) + define([trgti],[tdgti $@]) + define([srari],[sradi $@]) + define([srri],[srdi $@]) + define([srr],[srd $@]) + define([slri],[sldi $@]) + define([lrarx],[ldarx $@]) + define([strcx],[stdcx. $@]) define([load_highbit],[ - lis $1,0x8000 - sldi $1,$1,32 + __(lis $1,0x8000) + __(sldi $1,$1,32) ]) define([extract_bit_shift_count],[ - clrldi $1,$2,64-bitmap_shift + __(clrldi $1,$2,64-bitmap_shift) ]) define([alloc_trap],[ - tdlt allocptr,allocbase - ]) - define([mullr],[ - mulld $@ - ]) + __(tdlt allocptr,allocbase) + ]) + define([mullr],[mulld $@]) ],[ - define([clrrri],[ - clrrwi $@ - ]) - define([clrlri],[ - clrlwi $@ - ]) - define([clrlri_],[ - clrlwi. $@ - ]) - define([ldr],[ - lwz $@ - ]) - define([ldrx],[ - lwzx $@ - ]) - define([ldru],[ - lwzu $@ - ]) - define([str],[ - stw $@ - ]) - define([strx],[ - stwx $@ - ]) - define([stru],[ - stwu $@ - ]) - define([strux],[ - stwux $@ - ]) - define([cmpr],[ - cmpw $@ - ]) - define([cmpri],[ - cmpwi $@ - ]) - define([cmplr],[ - cmplw $@ - ]) - define([cmplri],[ - cmplwi $@ - ]) - define([trlge],[ - twlge $@ - ]) - define([trllt],[ - twllt $@ - ]) - define([trlt],[ - twlt $@ - ]) - define([trlle],[ - twlle $@ - ]) - define([treqi],[ - tweqi $@ - ]) - define([trnei],[ - twnei $@ - ]) - define([trgti],[ - twgti $@ - ]) - define([srari],[ - srawi $@ - ]) - define([srri],[ - srwi $@ - ]) - define([srr],[ - srw $@ - ]) - define([slri],[ - slwi $@ - ]) - define([lrarx],[ - lwarx $@ - ]) - define([strcx],[ - stwcx. $@ - ]) + define([clrrri],[clrrwi $@]) + define([clrlri],[clrlwi $@]) + define([clrlri_],[clrlwi. $@]) + define([ldr],[lwz $@]) + define([ldrx],[lwzx $@]) + define([ldru],[lwzu $@]) + define([str],[stw $@]) + define([strx],[stwx $@]) + define([stru],[stwu $@]) + define([strux],[stwux $@]) + define([cmpr],[cmpw $@]) + define([cmpri],[cmpwi $@]) + define([cmplr],[cmplw $@]) + define([cmplri],[cmplwi $@]) + define([trlge],[twlge $@]) + define([trllt],[twllt $@]) + define([trlt],[twlt $@]) + define([trlle],[twlle $@]) + define([treqi],[tweqi $@]) + define([trnei],[twnei $@]) + define([trgti],[twgti $@]) + define([srari],[srawi $@]) + define([srri],[srwi $@]) + define([srr],[srw $@]) + define([slri],[slwi $@]) + define([lrarx],[lwarx $@]) + define([strcx],[stwcx. $@]) define([load_highbit],[ - lis $1,0x8000 + __(lis $1,0x8000) ]) define([extract_bit_shift_count],[ - clrlwi $1,$2,32-bitmap_shift + __(clrlwi $1,$2,32-bitmap_shift) ]) define([alloc_trap],[ - twllt allocptr,allocbase - ]) - define([mullr],[ - mullw $@ - ]) + __(twllt allocptr,allocbase) + ]) + define([mullr],[mullw $@]) ]) /* dnode_align(dest,src,delta) */ define([dnode_align],[ - la $1,($3+(dnode_size-1))($2) - clrrri($1,$1,dnode_align_bits) + __(la $1,($3+(dnode_size-1))($2)) + __(clrrri($1,$1,dnode_align_bits)) ]) define([extract_fulltag],[ - clrlri($1,$2,nbits_in_word-ntagbits) + __(clrlri($1,$2,nbits_in_word-ntagbits)) ]) define([extract_lisptag],[ - clrlri($1,$2,nbits_in_word-nlisptagbits) + __(clrlri($1,$2,nbits_in_word-nlisptagbits)) ]) define([extract_lisptag_],[ - clrlri_($1,$2,nbits_in_word-nlisptagbits) + __(clrlri_($1,$2,nbits_in_word-nlisptagbits)) ]) define([extract_subtag],[ - lbz $1,misc_subtag_offset($2)]) + __(lbz $1,misc_subtag_offset($2)) + ]) ifdef([PPC64],[ define([extract_lowtag],[ - clrldi $1,$2,nbits_in_word-nlowtagbits + __(clrldi $1,$2,nbits_in_word-nlowtagbits) ]) define([trap_unless_lowtag_equal],[ - clrldi $3,$1,nbits_in_word-nlowtagbits - tdnei $3,$2 + __(clrldi $3,$1,nbits_in_word-nlowtagbits) + __(tdnei $3,$2) ]) ]) define([extract_lowbyte],[ - clrlri($1,$2,nbits_in_word-num_subtag_bits) + __(clrlri($1,$2,nbits_in_word-num_subtag_bits)) ]) define([extract_header],[ - ldr($1,misc_header_offset($2))]) + __(ldr($1,misc_header_offset($2))) + ]) @@ -273,91 +163,107 @@ define([extract_typecode],[ new_macro_labels() - extract_fulltag($1,$2) - cmpdi cr0,$1,fulltag_misc - extract_lisptag($1,$1) - bne cr0,macro_label(not_misc) - extract_subtag($1,$2) + __(extract_fulltag($1,$2)) + __(cmpdi cr0,$1,fulltag_misc) + __(extract_lisptag($1,$1)) + __(bne cr0,macro_label(not_misc)) + __(extract_subtag($1,$2)) macro_label(not_misc): ])],[ define([extract_typecode],[ new_macro_labels() - extract_lisptag($1,$2) - cmpwi cr0,$1,tag_misc - bne cr0,macro_label(not_misc) - extract_subtag($1,$2) + __(extract_lisptag($1,$2)) + __(cmpwi cr0,$1,tag_misc) + __(bne cr0,macro_label(not_misc)) + __(extract_subtag($1,$2)) macro_label(not_misc): ])]) define([box_fixnum],[ - slri($1,$2,fixnumshift)]) + __(slri($1,$2,fixnumshift)) + ]) define([unbox_fixnum],[ - srari($1,$2,fixnumshift)]) + __(srari($1,$2,fixnumshift)) + ]) define([loaddf],[ - lfd $1,dfloat.value($2)]) + __(lfd $1,dfloat.value($2))]) define([storedf],[ - stfd $1,dfloat.value($2)]) + __(stfd $1,dfloat.value($2)) + ]) define([push],[ - stru($1,-node_size($2))]) + __(stru($1,-node_size($2))) + ]) /* Generally not a great idea. */ define([pop],[ - ldr($1,0($2)) - la $2,node_size($2)]) + __(ldr($1,0($2))) + __(la $2,node_size($2)) + ]) define([vpush],[ - push($1,vsp)]) + __(push($1,vsp)) + ]) define([vpop],[ - pop($1,vsp)]) + __(pop($1,vsp)) + ]) define([unlink],[ - ldr($1,0($1)) + __(ldr($1,0($1))) ]) define([set_nargs],[ - lwi(nargs,($1)<spinlock),tcr); + LOCK_SPINLOCK(m->spinlock,tcr); ++m->avail; if (m->avail == 1) { m->owner = tcr; m->count = 1; - m->spinlock = 0; + RELEASE_SPINLOCK(m->spinlock); break; } - m->spinlock = 0; + RELEASE_SPINLOCK(m->spinlock); SEM_WAIT_FOREVER(m->signal); } @@ -131,5 +140,52 @@ } - +#else /* USE_FUTEX */ + +static void inline +lock_futex(natural *p) +{ + + while (1) { + if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) { + return; + } + while (1) { + if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) { + return; + } + futex_wait(p,FUTEX_CONTENDED); + } + } +} + +static void inline +unlock_futex(natural *p) +{ + if (atomic_decf(p) != FUTEX_AVAIL) { + *p = FUTEX_AVAIL; + futex_wake(p,INT_MAX); + } +} + +int +lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + natural val; + if (tcr == NULL) { + tcr = get_tcr(true); + } + if (m->owner == tcr) { + m->count++; + return 0; + } + lock_futex(&m->avail); + m->owner = tcr; + m->count = 1; + return 0; +} +#endif /* USE_FUTEX */ + + +#ifndef USE_FUTEX int unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) @@ -144,5 +200,5 @@ --m->count; if (m->count == 0) { - get_spin_lock(&(m->spinlock),tcr); + LOCK_SPINLOCK(m->spinlock,tcr); m->owner = NULL; pending = m->avail-1 + m->waiting; /* Don't count us */ @@ -154,5 +210,5 @@ m->waiting = 0; } - m->spinlock = 0; + RELEASE_SPINLOCK(m->spinlock); if (pending >= 0) { SEM_RAISE(m->signal); @@ -163,9 +219,32 @@ return ret; } +#else /* USE_FUTEX */ +int +unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + int ret = EPERM, pending; + + if (tcr == NULL) { + tcr = get_tcr(true); + } + + if (m->owner == tcr) { + --m->count; + if (m->count == 0) { + m->owner = NULL; + unlock_futex(&m->avail); + } + ret = 0; + } + return ret; +} +#endif /* USE_FUTEX */ void destroy_recursive_lock(RECURSIVE_LOCK m) { +#ifndef USE_FUTEX destroy_semaphore((void **)&m->signal); +#endif postGCfree((void *)(m->malloced_ptr)); } @@ -177,4 +256,33 @@ */ +#ifndef USE_FUTEX +int +recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free) +{ + TCR *owner = m->owner; + + LOCK_SPINLOCK(m->spinlock,tcr); + if (owner == tcr) { + m->count++; + if (was_free) { + *was_free = 0; + RELEASE_SPINLOCK(m->spinlock); + return 0; + } + } + if (store_conditional((natural*)&(m->avail), 0, 1) == 0) { + m->owner = tcr; + m->count = 1; + if (was_free) { + *was_free = 1; + } + RELEASE_SPINLOCK(m->spinlock); + return 0; + } + + RELEASE_SPINLOCK(m->spinlock); + return EBUSY; +} +#else int recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free) @@ -200,4 +308,5 @@ return EBUSY; } +#endif void @@ -221,13 +330,13 @@ int -wait_on_semaphore(SEMAPHORE s, int seconds, int millis) +wait_on_semaphore(void *s, int seconds, int millis) { int nanos = (millis % 1000) * 1000000; -#if defined(LINUX) || defined(FREEBSD) +#ifdef USE_POSIX_SEMAPHORES int status; struct timespec q; gettimeofday((struct timeval *)&q, NULL); - q.tv_nsec *= 1000L; + q.tv_nsec *= 1000L; /* microseconds -> nanoseconds */ q.tv_nsec += nanos; @@ -259,4 +368,14 @@ +int +semaphore_maybe_timedwait(void *s, struct timespec *t) +{ + if (t) { + return wait_on_semaphore(s, t->tv_sec, t->tv_nsec/1000000L); + } + SEM_WAIT_FOREVER(s); + return 0; +} + void signal_semaphore(SEMAPHORE s) @@ -298,26 +417,29 @@ TCR *tcr = get_interrupt_tcr(false); - if (signo == thread_suspend_signal) { + if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<suspend_context = context; + sigset_t wait_for; +#endif + + tcr->suspend_context = context; #if 0 - sigfillset(&wait_for); -#endif - SEM_RAISE(tcr->suspend); + sigfillset(&wait_for); +#endif + SEM_RAISE(tcr->suspend); #if 0 - sigdelset(&wait_for, thread_resume_signal); + sigdelset(&wait_for, thread_resume_signal); #endif #if 1 #if RESUME_VIA_RESUME_SEMAPHORE - SEM_WAIT_FOREVER(tcr->resume); + SEM_WAIT_FOREVER(tcr->resume); #if SUSPEND_RESUME_VERBOSE - fprintf(stderr, "got resume in 0x%x\n",tcr); -#endif - tcr->suspend_context = NULL; + fprintf(stderr, "got resume in 0x%x\n",tcr); +#endif + tcr->suspend_context = NULL; #else - sigsuspend(&wait_for); + sigsuspend(&wait_for); #endif #else @@ -326,13 +448,14 @@ } while (tcr->suspend_context); #endif - } else { - tcr->suspend_context = NULL; + } else { + tcr->suspend_context = NULL; #if SUSEPEND_RESUME_VERBOSE - fprintf(stderr,"got resume in in 0x%x\n",tcr); -#endif - } + fprintf(stderr,"got resume in in 0x%x\n",tcr); +#endif + } #if WAIT_FOR_RESUME_ACK - SEM_RAISE(tcr->suspend); -#endif + SEM_RAISE(tcr->suspend); +#endif + } #ifdef DARWIN_GS_HACK if (gs_was_tcr) { @@ -407,5 +530,7 @@ void *p = calloc(1,sizeof(_recursive_lock)+cache_block_size-1); RECURSIVE_LOCK m = NULL; +#ifndef USE_FUTEX void *signal = new_semaphore(0); +#endif if (p) { @@ -414,4 +539,9 @@ } +#ifdef USE_FUTEX + if (m) { + return m; + } +#else if (m && signal) { m->signal = signal; @@ -424,4 +554,5 @@ destroy_semaphore(&signal); } +#endif return NULL; } @@ -573,12 +704,10 @@ #ifdef HAVE_TLS TCR *tcr = ¤t_tcr; +#else + TCR *tcr = allocate_tcr(); +#endif + #ifdef X8664 setup_tcr_extra_segment(tcr); -#endif -#else - TCR *tcr = allocate_tcr(); -#endif - -#ifdef X8664 tcr->linear = tcr; #endif @@ -827,4 +956,5 @@ Boolean threads_initialized = false; +#ifndef USE_FUTEX void count_cpus() @@ -850,4 +980,6 @@ #endif } +#endif + void @@ -857,5 +989,8 @@ pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr); thread_signal_setup(); + +#ifndef USE_FUTEX count_cpus(); +#endif threads_initialized = true; } @@ -1335,158 +1470,33 @@ -/* - Try to take an rwquentry off of the rwlock's freelist; failing that, - malloc one. The caller owns the lock on the rwlock itself, of course. - -*/ -rwquentry * -recover_rwquentry(rwlock *rw) -{ - rwquentry *freelist = &(rw->freelist), - *p = freelist->next, - *follow = p->next; - - if (p == freelist) { - p = NULL; - } else { - follow->prev = freelist; - freelist->next = follow; - p->prev = p->next = NULL; - p->tcr = NULL; - p->count = 0; - } - return p; -} - -rwquentry * -new_rwquentry(rwlock *rw) -{ - rwquentry *p = recover_rwquentry(rw); - - if (p == NULL) { - p = calloc(1, sizeof(rwquentry)); - } - return p; -} - - -void -free_rwquentry(rwquentry *p, rwlock *rw) -{ - rwquentry - *prev = p->prev, - *next = p->next, - *freelist = &(rw->freelist), - *follow = freelist->next; - - prev->next = next; - next->prev = prev; - p->prev = freelist; - freelist->next = p; - follow->prev = p; - p->next = follow; - p->prev = freelist; -} - -void -add_rwquentry(rwquentry *p, rwlock *rw) -{ - rwquentry - *head = &(rw->head), - *follow = head->next; - - head->next = p; - follow->prev = p; - p->next = follow; - p->prev = head; -} - -rwquentry * -find_enqueued_tcr(TCR *target, rwlock *rw) -{ - rwquentry - *head = &(rw->head), - *p = head->next; - - do { - if (p->tcr == target) { - return p; - } - p = p->next; - } while (p != head); - return NULL; -} - + rwlock * rwlock_new() { - rwlock *rw = calloc(1, sizeof(rwlock)); - - if (rw) { - pthread_mutex_t *lock = calloc(1, sizeof(pthread_mutex_t)); - if (lock == NULL) { - free (rw); + extern int cache_block_size; + + void *p = calloc(1,sizeof(rwlock)+cache_block_size-1); + rwlock *rw; + + if (p) { + rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1))); + rw->malloced_ptr = p; +#ifndef USE_FUTEX + rw->reader_signal = new_semaphore(0); + rw->writer_signal = new_semaphore(0); + if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) { + if (rw->reader_signal) { + destroy_semaphore(&(rw->reader_signal)); + } else { + destroy_semaphore(&(rw->writer_signal)); + } + free(rw); rw = NULL; - } else { - pthread_cond_t *reader_signal = calloc(1, sizeof(pthread_cond_t)); - pthread_cond_t *writer_signal = calloc(1, sizeof(pthread_cond_t)); - if ((reader_signal == NULL) || (writer_signal == NULL)) { - if (reader_signal) { - free(reader_signal); - } else { - free(writer_signal); - } - - free(lock); - free(rw); - rw = NULL; - } else { - pthread_mutex_init(lock, NULL); - pthread_cond_init(reader_signal, NULL); - pthread_cond_init(writer_signal, NULL); - rw->lock = lock; - rw->reader_signal = reader_signal; - rw->writer_signal = writer_signal; - rw->head.prev = rw->head.next = &(rw->head); - rw->freelist.prev = rw->freelist.next = &(rw->freelist); - } - } + } +#endif } return rw; } -/* - no thread should be waiting on the lock, and the caller has just - unlocked it. -*/ -static void -rwlock_delete(rwlock *rw) -{ - pthread_mutex_t *lock = rw->lock; - pthread_cond_t *cond; - rwquentry *entry; - - rw->lock = NULL; - cond = rw->reader_signal; - rw->reader_signal = NULL; - pthread_cond_destroy(cond); - free(cond); - cond = rw->writer_signal; - rw->writer_signal = NULL; - pthread_cond_destroy(cond); - free(cond); - while (entry = recover_rwquentry(rw)) { - free(entry); - } - free(rw); - pthread_mutex_unlock(lock); - free(lock); -} - -void -rwlock_rlock_cleanup(void *arg) -{ - pthread_mutex_unlock((pthread_mutex_t *)arg); -} /* @@ -1498,81 +1508,69 @@ hold read access once. */ +#ifndef USE_FUTEX int rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) { - pthread_mutex_t *lock = rw->lock; - rwquentry *entry; int err = 0; - - - pthread_mutex_lock(lock); - - if (RWLOCK_WRITER(rw) == tcr) { - pthread_mutex_unlock(lock); + + LOCK_SPINLOCK(rw->spin, tcr); + + if (rw->writer == tcr) { + RELEASE_SPINLOCK(rw->spin); return EDEADLK; } - if (rw->state > 0) { - /* already some readers, we may be one of them */ - entry = find_enqueued_tcr(tcr, rw); - if (entry) { - entry->count++; - rw->state++; - pthread_mutex_unlock(lock); + while (rw->blocked_writers || (rw->state > 0)) { + rw->blocked_readers++; + RELEASE_SPINLOCK(rw->spin); + err = semaphore_maybe_timedwait(rw->reader_signal,waitfor); + LOCK_SPINLOCK(rw->spin,tcr); + rw->blocked_readers--; + if (err == EINTR) { + err = 0; + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + } + rw->state--; + RELEASE_SPINLOCK(rw->spin); + return err; +} +#else +int +rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + natural waitval; + + lock_futex(&rw->spin); + + if (rw->writer == tcr) { + unlock_futex(&rw->spin); + return EDEADLOCK; + } + while (1) { + if (rw->writer == NULL) { + --rw->state; + unlock_futex(&rw->spin); return 0; } - } - entry = new_rwquentry(rw); - entry->tcr = tcr; - entry->count = 1; - - pthread_cleanup_push(rwlock_rlock_cleanup,lock); - - /* Wait for current and pending writers */ - while ((err == 0) && ((rw->state < 0) || (rw->write_wait_count > 0))) { - if (waitfor) { - if (pthread_cond_timedwait(rw->reader_signal, lock, waitfor)) { - err = errno; - } - } else { - pthread_cond_wait(rw->reader_signal, lock); - } - } - - if (err == 0) { - add_rwquentry(entry, rw); - rw->state++; - } - - pthread_cleanup_pop(1); - return err; -} - - -/* - This is here to support cancelation. Cancelation is evil. -*/ - -void -rwlock_wlock_cleanup(void *arg) -{ - rwlock *rw = (rwlock *)arg; - - /* If this thread was the only queued writer and the lock - is now available for reading, tell any threads that're - waiting for read access. - This thread owns the lock on the rwlock itself. - */ - if ((--(rw->write_wait_count) == 0) && - (rw->state >= 0)) { - pthread_cond_broadcast(rw->reader_signal); - } - - pthread_mutex_unlock(rw->lock); -} + rw->blocked_readers++; + waitval = rw->reader_signal; + unlock_futex(&rw->spin); + futex_wait(&rw->reader_signal,waitval); + lock_futex(&rw->spin); + rw->blocked_readers--; + } + return 0; +} +#endif + /* Try to obtain write access to the lock. - If we already have read access, fail with EDEADLK. + It is an error if we already have read access, but it's hard to + detect that. If we already have write access, increment the count that indicates that. @@ -1581,146 +1579,245 @@ */ +#ifndef USE_FUTEX int rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) { - pthread_mutex_t *lock = rw->lock; - rwquentry *entry; int err = 0; - - pthread_mutex_lock(lock); - if (RWLOCK_WRITER(rw) == tcr) { - --RWLOCK_WRITE_COUNT(rw); - --rw->state; - pthread_mutex_unlock(lock); + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->writer == tcr) { + rw->state++; + RELEASE_SPINLOCK(rw->spin); return 0; } - - if (rw->state > 0) { - /* already some readers, we may be one of them */ - entry = find_enqueued_tcr(tcr, rw); - if (entry) { - pthread_mutex_unlock(lock); - return EDEADLK; - } - } - rw->write_wait_count++; - pthread_cleanup_push(rwlock_wlock_cleanup,rw); - - while ((err == 0) && (rw->state) != 0) { - if (waitfor) { - if (pthread_cond_timedwait(rw->writer_signal, lock, waitfor)) { - err = errno; - } - } else { - pthread_cond_wait(rw->writer_signal, lock); - } - } - if (err == 0) { - RWLOCK_WRITER(rw) = tcr; - RWLOCK_WRITE_COUNT(rw) = -1; - rw->state = -1; - } - pthread_cleanup_pop(1); + + while (rw->state != 0) { + rw->blocked_writers++; + RELEASE_SPINLOCK(rw->spin); + err = semaphore_maybe_timedwait(rw->writer_signal, waitfor); + LOCK_SPINLOCK(rw->spin,tcr); + rw->blocked_writers--; + if (err = EINTR) { + err = 0; + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + } + rw->state = 1; + rw->writer = tcr; + RELEASE_SPINLOCK(rw->spin); return err; } + +#else +int +rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + natural waitval; + + lock_futex(&rw->spin); + if (rw->writer == tcr) { + rw->state++; + unlock_futex(&rw->spin); + return 0; + } + + while (rw->state != 0) { + rw->blocked_writers++; + waitval = rw->writer_signal; + unlock_futex(&rw->spin); + futex_wait(&rw->writer_signal,waitval); + lock_futex(&rw->spin); + rw->blocked_writers--; + } + rw->state = 1; + rw->writer = tcr; + unlock_futex(&rw->spin); + return err; +} +#endif /* Sort of the same as above, only return EBUSY if we'd have to wait. - In partucular, distinguish between the cases of "some other readers - (EBUSY) another writer/queued writer(s)" (EWOULDBLOK) and "we hold a - read lock" (EDEADLK.) */ +#ifndef USE_FUTEX int rwlock_try_wlock(rwlock *rw, TCR *tcr) { - pthread_mutex_t *lock = rw->lock; - rwquentry *entry; int ret = EBUSY; - pthread_mutex_lock(lock); - if ((RWLOCK_WRITER(rw) == tcr) || - ((rw->state == 0) && (rw->write_wait_count == 0))) { - RWLOCK_WRITER(rw) = tcr; - --RWLOCK_WRITE_COUNT(rw); + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->writer == tcr) { + rw->state++; + ret = 0; + } else { + if (rw->state == 0) { + rw->writer = tcr; + rw->state = 1; + ret = 0; + } + } + RELEASE_SPINLOCK(rw->spin); + return ret; +} +#else +int +rwlock_try_wlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + lock_futex(&rw->spin); + if (rw->writer == tcr) { + rw->state++; + ret = 0; + } else { + if (rw->state == 0) { + rw->writer = tcr; + rw->state = 1; + ret = 0; + } + } + unlock_futex(&rw->spin); + return ret; +} +#endif + +#ifndef USE_FUTEX +int +rwlock_try_rlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->state <= 0) { --rw->state; - pthread_mutex_unlock(lock); - return 0; - } - - if (rw->state > 0) { - /* already some readers, we may be one of them */ - entry = find_enqueued_tcr(tcr, rw); - if (entry) { - ret = EDEADLK; - } - } else { - /* another writer or queued writers */ - ret = EWOULDBLOCK; - } - pthread_mutex_unlock(rw->lock); + ret = 0; + } + RELEASE_SPINLOCK(rw->spin); return ret; } - -/* - "Upgrade" a lock held once or more for reading to one held the same - number of times for writing. - Upgraders have higher priority than writers do -*/ - +#else int -rwlock_read_to_write(rwlock *rw, TCR *tcr) -{ -} - - +rwlock_try_rlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + lock_futex(&rw->spin); + if (rw->state <= 0) { + --rw->state; + ret = 0; + } + unlock_futex(&rw->spin); + return ret; +} +#endif + + + +#ifndef USE_FUTEX int rwlock_unlock(rwlock *rw, TCR *tcr) { - rwquentry *entry; - - pthread_mutex_lock(rw->lock); - if (rw->state < 0) { - /* Locked for writing. By us ? */ - if (RWLOCK_WRITER(rw) != tcr) { - pthread_mutex_unlock(rw->lock); - /* Can't unlock: locked for writing by another thread. */ - return EPERM; - } - if (++RWLOCK_WRITE_COUNT(rw) == 0) { - rw->state = 0; - RWLOCK_WRITER(rw) = NULL; - if (rw->write_wait_count) { - pthread_cond_signal(rw->writer_signal); - } else { - pthread_cond_broadcast(rw->reader_signal); + + int err = 0; + natural blocked_readers = 0; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->state > 0) { + if (rw->writer != tcr) { + err = EINVAL; + } else { + --rw->state; + if (rw->state == 0) { + rw->writer = NULL; } } - pthread_mutex_unlock(rw->lock); - return 0; - } - entry = find_enqueued_tcr(tcr, rw); - if (entry == NULL) { - /* Not locked for reading by us, so why are we unlocking it ? */ - pthread_mutex_unlock(rw->lock); - return EPERM; - } - if (--entry->count == 0) { - free_rwquentry(entry, rw); - } - if (--rw->state == 0) { - pthread_cond_signal(rw->writer_signal); - } - pthread_mutex_unlock(rw->lock); + } else { + if (rw->state < 0) { + ++rw->state; + } else { + err = EINVAL; + } + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + + if (rw->state == 0) { + if (rw->blocked_writers) { + SEM_RAISE(rw->writer_signal); + } else { + blocked_readers = rw->blocked_readers; + if (blocked_readers) { + SEM_BROADCAST(rw->reader_signal, blocked_readers); + } + } + } + RELEASE_SPINLOCK(rw->spin); return 0; } +#else +int +rwlock_unlock(rwlock *rw, TCR *tcr) +{ + + int err = 0; + + lock_futex(&rw->spin); + if (rw->state > 0) { + if (rw->writer != tcr) { + err = EINVAL; + } else { + --rw->state; + if (rw->state == 0) { + rw->writer = NULL; + } + } + } else { + if (rw->state < 0) { + ++rw->state; + } else { + err = EINVAL; + } + } + if (err) { + unlock_futex(&rw->spin); + return err; + } + + if (rw->state == 0) { + if (rw->blocked_writers) { + ++rw->writer_signal; + unlock_futex(&rw->spin); + futex_wake(&rw->writer_signal,1); + return 0; + } + if (rw->blocked_readers) { + ++rw->reader_signal; + unlock_futex(&rw->spin); + futex_wake(&rw->reader_signal, INT_MAX); + return 0; + } + } + unlock_futex(&rw->spin); + return 0; +} +#endif -int +void rwlock_destroy(rwlock *rw) { - return 0; /* for now. */ -} - - - +#ifndef USE_FUTEX + destroy_semaphore((void **)&rw->reader_signal); + destroy_semaphore((void **)&rw->writer_signal); +#endif + postGCfree((void *)(rw->malloced_ptr)); +} + + + Index: /branches/event-ide/ccl/lisp-kernel/win64/Makefile =================================================================== --- /branches/event-ide/ccl/lisp-kernel/win64/Makefile (revision 8262) +++ /branches/event-ide/ccl/lisp-kernel/win64/Makefile (revision 8262) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2005 Clozure Associates +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +CC = x86_64-pc-mingw32-gcc +AS = x86_64-pc-mingw32-as +M4 = m4 +ASFLAGS = --64 +M4FLAGS = -DWIN64 -DWINDOWS -DX86 -DX8664 -DHAVE_TLS -DEMUTLS +CDEFINES = -DWIN64 -DWINDOWS -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DEMUTLS #-DDISABLE_EGC +CDEBUG = -g +COPT = -O2 + +# If the linker supports a "--hash-style=" option, use traditional +# SysV hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m64 -o $@ + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils64.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../wx86cl64 + + +OSLIBS = -ldl -lm -lpthread + + +../../wx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ $(USE_LINK_MAP) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../wx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../wx86cl64 + strip -g ../../wx86cl64 Index: /branches/event-ide/ccl/lisp-kernel/x86-asmutils64.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-asmutils64.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-asmutils64.s (revision 8262) @@ -173,5 +173,5 @@ __ifdef([DARWIN_GS_HACK]) -/* Check (in and ugly, non-portale way) to see if %gs is addressing +/* Check (in and ugly, non-portable way) to see if %gs is addressing pthreads data. If it was, return 0; otherwise, assume that it's addressing a lisp tcr and set %gs to point to the tcr's tcr.osid, Index: /branches/event-ide/ccl/lisp-kernel/x86-constants.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-constants.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-constants.h (revision 8262) @@ -25,4 +25,5 @@ #define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) #define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) +#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) #define TCR_STATE_FOREIGN (1) #define TCR_STATE_LISP (0) Index: /branches/event-ide/ccl/lisp-kernel/x86-constants64.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-constants64.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-constants64.h (revision 8262) @@ -57,4 +57,25 @@ #endif +#ifdef WIN64 +/* DWORD64 indices in CONTEXT */ +#define REG_RAX 15 +#define REG_RCX 16 +#define REG_RDX 17 +#define REG_RBX 18 +#define REG_RSP 19 +#define REG_RBP 20 +#define REG_RSI 21 +#define REG_RDI 22 +#define REG_R8 23 +#define REG_R9 24 +#define REG_R10 25 +#define REG_R11 26 +#define REG_R12 27 +#define REG_R13 28 +#define REG_R14 29 +#define REG_R15 30 +#define REG_RIP 31 +#define REG_EFL 8 /* In the high 32 bits of the 64-bit word at index 8 */ +#endif /* Define indices of the GPRs in the mcontext component of a ucontext */ #define Itemp0 REG_RBX @@ -309,4 +330,6 @@ LispObj xp; /* exception context */ LispObj ra0; /* value of ra0 from context */ + LispObj foreign_sp; /* foreign sp at the time that exception occurred */ + LispObj prev_xframe; /* so %apply-in-frame can unwind it */ } xcf; Index: /branches/event-ide/ccl/lisp-kernel/x86-constants64.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-constants64.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-constants64.s (revision 8262) @@ -382,9 +382,16 @@ _struct(tsp_frame,0) _node(backlink) - _node(type) + _node(save_rbp) _struct_label(fixed_overhead) _struct_label(data_offset) _ends + _struct(csp_frame,0) + _node(backlink) + _node(save_rbp) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + @@ -753,4 +760,5 @@ TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) target_most_positive_fixnum = 1152921504606846975 Index: /branches/event-ide/ccl/lisp-kernel/x86-exceptions.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-exceptions.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-exceptions.c (revision 8262) @@ -233,11 +233,15 @@ fatal_oserr(": save_application", err); } - if (selector == GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE) { - LispObj aligned_arg = align_to_power_of_2(arg, log2_nbits_in_word); - signed_natural - delta_dnodes = ((signed_natural) aligned_arg) - - ((signed_natural) tenured_area->static_dnodes); - change_hons_area_size_from_xp(xp, delta_dnodes*dnode_size); - xpGPR(xp, Iimm0) = tenured_area->static_dnodes; + switch (selector) { + case GC_TRAP_FUNCTION_SET_HONS_AREA_SIZE: + xpGPR(xp, Iimm0) = 0; + break; + case GC_TRAP_FUNCTION_FREEZE: + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift; + break; + default: + break; } if (egc_was_enabled) { @@ -272,10 +276,10 @@ LispObj *vsp = (LispObj *) xpGPR(xp,Isp), ra = *vsp++; - + xpGPR(xp,Isp) = (LispObj) vsp; + if (disp > 0) { /* implies that nargs > 3 */ vsp[disp] = xpGPR(xp,Irbp); vsp[disp+1] = ra; xpGPR(xp,Irbp) = (LispObj)(vsp+disp); - xpGPR(xp,Isp) = (LispObj)vsp; push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); push_on_lisp_stack(xp,xpGPR(xp,Iarg_y)); @@ -311,5 +315,5 @@ LispObj -create_exception_callback_frame(ExceptionInformation *xp) +create_exception_callback_frame(ExceptionInformation *xp, TCR *tcr) { LispObj containing_uvector = 0, @@ -366,5 +370,6 @@ relative_pc = abs_pc << fixnumshift; } - + push_on_lisp_stack(xp,(LispObj)(tcr->xframe->prev)); + push_on_lisp_stack(xp,(LispObj)(tcr->foreign_sp)); push_on_lisp_stack(xp,tra); push_on_lisp_stack(xp,(LispObj)xp); @@ -404,5 +409,5 @@ { - LispObj xcf = create_exception_callback_frame(xp), + LispObj xcf = create_exception_callback_frame(xp, tcr), cmain = nrs_CMAIN.vcell; int skip; @@ -454,5 +459,5 @@ *save_vsp = (LispObj *)xpGPR(xp,Isp), word_beyond_vsp = save_vsp[-1], - xcf = create_exception_callback_frame(xp); + xcf = create_exception_callback_frame(xp, tcr); int save_errno = errno; @@ -469,6 +474,6 @@ pc program_counter = (pc)xpPC(xp); unsigned char op0 = program_counter[0], op1 = program_counter[1]; - LispObj rpc = (LispObj) program_counter, errdisp = nrs_ERRDISP.vcell, - save_rbp = xpGPR(xp,Irbp), save_vsp = xpGPR(xp,Isp), xcf; + LispObj rpc, errdisp = nrs_ERRDISP.vcell, + save_rbp = xpGPR(xp,Irbp), save_vsp = xpGPR(xp,Isp), xcf0; int skip; @@ -479,6 +484,19 @@ finish_function_entry(xp); } - xcf = create_exception_callback_frame(xp); - skip = callback_to_lisp(tcr, errdisp, xp, xcf, 0, 0, 0, 0); + xcf0 = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, errdisp, xp, xcf0, 0, 0, 0, 0); + if (skip == -1) { + xcf *xcf1 = (xcf *)xcf0; + LispObj container = xcf1->containing_uvector; + + rpc = xcf1->relative_pc >> fixnumshift; + if (container == lisp_nil) { + xpPC(xp) = rpc; + } else { + xpPC(xp) = (LispObj)(&(deref(container,1)))+rpc; + } + + skip = 0; + } xpGPR(xp,Irbp) = save_rbp; xpGPR(xp,Isp) = save_vsp; @@ -574,5 +592,5 @@ soft = a->softprot; unprotect_area(soft); - xcf = create_exception_callback_frame(xp); + xcf = create_exception_callback_frame(xp, tcr); skip = callback_to_lisp(tcr, nrs_CMAIN.vcell, xp, xcf, SIGSEGV, on_TSP, 0, 0); xpGPR(xp,Irbp) = save_rbp; @@ -625,5 +643,5 @@ if ((fulltag_of(cmain) == fulltag_misc) && (header_subtag(header_of(cmain)) == subtag_macptr)) { - xcf = create_exception_callback_frame(xp); + xcf = create_exception_callback_frame(xp, tcr); callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, is_write_fault(xp,info), (natural)addr, 0); } @@ -643,5 +661,5 @@ if ((fulltag_of(cmain) == fulltag_misc) && (header_subtag(header_of(cmain)) == subtag_macptr)) { - xcf = create_exception_callback_frame(xp); + xcf = create_exception_callback_frame(xp, tcr); skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0); xpPC(xp) += skip; @@ -795,5 +813,5 @@ get_lisp_string(xpGPR(context,Iarg_z),msg, sizeof(msg)-1); - lisp_Debugger(context, info, debug_entry_dbg, false, msg); + lisp_Debugger(context, info, debug_entry_dbg, false, msg); } return true; @@ -833,4 +851,8 @@ xpPC(context)+=3; return true; + + case XUUO_SUSPEND_NOW: + xpPC(context)+=3; + return true; default: @@ -958,4 +980,8 @@ old_valence = prepare_to_wait_for_exception_lock(tcr, context); #endif + if (tcr->flags & (1<regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context)); - if (lisp_Debugger(context, info, signum, foreign, msg)) { + if (lisp_Debugger(context, info, signum, foreign, msg)) { SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); } @@ -1139,5 +1165,5 @@ arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context) { - TCR *tcr = get_interrupt_tcr(false); + TCR *tcr = get_interrupt_tcr(false); #if 1 if (tcr->valence != TCR_STATE_LISP) { @@ -1148,4 +1174,5 @@ area *vs = tcr->vs_area; BytePtr current_sp = (BytePtr) current_stack_pointer(); + if ((current_sp >= vs->low) && @@ -1186,4 +1213,13 @@ #endif +Boolean +stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr) +{ + area *a = tcr->vs_area; + + return (((BytePtr)stack_pointer <= a->high) && + ((BytePtr)stack_pointer > a->low)); +} + void interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) @@ -1196,5 +1232,7 @@ if ((TCR_INTERRUPT_LEVEL(tcr) < 0) || (tcr->valence != TCR_STATE_LISP) || - (tcr->unwinding != 0)) { + (tcr->unwinding != 0) || + ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) || + ! stack_pointer_on_vstack_p(xpGPR(context,Irbp), tcr)) { tcr->interrupt_pending = (1L << (nbits_in_word - 1L)); } else { @@ -1217,14 +1255,4 @@ natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION); - { - BytePtr interrupted_sp = (BytePtr)xpGPR(context, Isp); - area *vs_area = tcr->vs_area; - - if ((interrupted_sp < vs_area->low) || - (interrupted_sp > vs_area->high)) { - Bug(context, "lisp stack pointer not in lisp stack"); - } - } - tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION); @@ -1335,5 +1363,5 @@ #endif sa.sa_flags = - SA_RESTART + 0 /* SA_RESTART */ #ifdef USE_SIGALTSTACK | SA_ONSTACK @@ -1938,10 +1966,4 @@ int -change_hons_area_size_from_xp(ExceptionInformation *xp, signed_natural delta_in_bytes) -{ - return gc_like_from_xp(xp, change_hons_area_size, delta_in_bytes); -} - -int purify_from_xp(ExceptionInformation *xp, signed_natural param) { @@ -2154,5 +2176,5 @@ raise_pending_interrupt(tcr); } else { - FBug(NULL, "no xp here!\n"); + Bug(NULL, "no xp here!\n"); } #ifdef DEBUG_MACH_EXCEPTIONS @@ -2202,5 +2224,5 @@ #endif - bcopy(ts,&(mc->__ss),sizeof(*ts)); + memmove(&(mc->__ss),ts,sizeof(*ts)); thread_state_count = x86_FLOAT_STATE64_COUNT; Index: /branches/event-ide/ccl/lisp-kernel/x86-exceptions.h =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-exceptions.h (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-exceptions.h (revision 8262) @@ -70,4 +70,9 @@ #endif +#ifdef WIN64 +#define xpGPRvector(x) ((DWORD64 *)((x)->ContextRecord)) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define xpPC(x) xpGPR(x,Iip); +#endif #ifdef DARWIN @@ -99,4 +104,5 @@ #define XUUO_TLB_TOO_SMALL 1 #define XUUO_INTERRUPT_NOW 2 +#define XUUO_SUSPEND_NOW 3 void @@ -146,6 +152,6 @@ #undef USE_SIGALTSTACK #else -/* #define USE_SIGALTSTACK 1 */ -#undef USE_SIGALTSTACK +#define USE_SIGALTSTACK 1 +/* #undef USE_SIGALTSTACK */ #endif Index: /branches/event-ide/ccl/lisp-kernel/x86-gc.c =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-gc.c (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-gc.c (revision 8262) @@ -26,52 +26,4 @@ #include -#ifndef timeradd -# define timeradd(a, b, result) \ - do { \ - (result)->tv_sec = (a)->tv_sec + (b)->tv_sec; \ - (result)->tv_usec = (a)->tv_usec + (b)->tv_usec; \ - if ((result)->tv_usec >= 1000000) \ - { \ - ++(result)->tv_sec; \ - (result)->tv_usec -= 1000000; \ - } \ - } while (0) -#endif -#ifndef timersub -# define timersub(a, b, result) \ - do { \ - (result)->tv_sec = (a)->tv_sec - (b)->tv_sec; \ - (result)->tv_usec = (a)->tv_usec - (b)->tv_usec; \ - if ((result)->tv_usec < 0) { \ - --(result)->tv_sec; \ - (result)->tv_usec += 1000000; \ - } \ - } while (0) -#endif - - -void -comma_output_decimal(char *buf, int len, natural n) -{ - int nout = 0; - - buf[--len] = 0; - do { - buf[--len] = n%10+'0'; - n = n/10; - if (n == 0) { - while (len) { - buf[--len] = ' '; - } - return; - } - if (len == 0) return; - nout ++; - if (nout == 3) { - buf[--len] = ','; - nout = 0; - } - } while (len >= 0); -} /* Heap sanity checking. */ @@ -186,5 +138,4 @@ -Boolean GCDebug = false, GCverbose = false; @@ -279,26 +230,9 @@ } -natural -static_dnodes_for_area(area *a) -{ - if (a->low == tenured_area->low) { - return tenured_area->static_dnodes; - } - return 0; -} - - - - - - - - -bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL; -LispObj GCarealow, GCareadynamiclow; -natural GCndnodes_in_area, GCndynamic_dnodes_in_area; -LispObj GCweakvll = (LispObj)NULL; -LispObj GCephemeral_low; -natural GCn_ephemeral_dnodes; + + + + + @@ -391,8 +325,8 @@ ((hash_table_vector_header *) base)->cache_key = undefined; ((hash_table_vector_header *) base)->cache_value = lisp_nil; - } - deref(ptr_to_lispobj(base),1) = GCweakvll; - GCweakvll = n; - return; + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = n; + return; + } } @@ -468,6 +402,4 @@ #endif -natural -GCstack_limit = 0; @@ -562,8 +494,8 @@ ((hash_table_vector_header *) base)->cache_key = undefined; ((hash_table_vector_header *) base)->cache_value = lisp_nil; - } - deref(ptr_to_lispobj(base),1) = GCweakvll; - GCweakvll = n; - return; + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = n; + return; + } } @@ -802,9 +734,8 @@ ((hash_table_vector_header *) base)->cache_key = undefined; ((hash_table_vector_header *) base)->cache_value = lisp_nil; - } - - deref(ptr_to_lispobj(base),1) = GCweakvll; - GCweakvll = this; - goto Climb; + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = this; + goto Climb; + } } @@ -1067,31 +998,29 @@ ((hash_table_vector_header *) start)->cache_key = undefined; ((hash_table_vector_header *) start)->cache_value = lisp_nil; - } - - start[1] = GCweakvll; - GCweakvll = (LispObj) (((natural) start) + fulltag_misc); - } else { - - if (subtag == subtag_pool) { - start[1] = lisp_nil; - } - - if (subtag == subtag_weak) { - natural weak_type = (natural) start[2]; - if (weak_type >> population_termination_bit) - element_count -= 2; - else - element_count -= 1; - start[1] = GCweakvll; - GCweakvll = (LispObj) (((natural) start) + fulltag_misc); - } - - base = start + element_count + 1; - if (subtag == subtag_function) { - element_count -= (int)start[1]; + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + element_count = 0; } - while(element_count--) { - mark_root(*--base); - } + } + if (subtag == subtag_pool) { + start[1] = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) start[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + } + + base = start + element_count + 1; + if (subtag == subtag_function) { + element_count -= (int)start[1]; + } + while(element_count--) { + mark_root(*--base); } start += size; @@ -1143,349 +1072,10 @@ } - -void -reapweakv(LispObj weakv) -{ - /* - element 2 of the weak vector should be tagged as a cons: if it - isn't, just mark it as a root. if it is, cdr through it until a - "marked" cons is encountered. If the car of any unmarked cons is - marked, mark the cons which contains it; otherwise, splice the - cons out of the list. N.B. : elements 0 and 1 are already marked - (or are immediate, etc.) - */ - LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev; - LispObj termination_list = lisp_nil; - natural weak_type = (natural) deref(weakv,2); - Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist), - terminatablep = ((weak_type >> population_termination_bit) != 0); - Boolean done = false; - cons *rawcons; - natural dnode, car_dnode; - bitvector markbits = GCmarkbits; - - if (terminatablep) { - termination_list = deref(weakv,1+3); - } - - if (fulltag_of(cell) != fulltag_cons) { - mark_root(cell); - } else if (alistp) { - /* weak alist */ - while (! done) { - dnode = gc_area_dnode(cell); - if ((dnode >= GCndnodes_in_area) || - (ref_bit(markbits, dnode))) { - done = true; - } else { - /* Cons cell is unmarked. */ - LispObj alist_cell, thecar; - unsigned cell_tag; - - rawcons = (cons *) ptr_from_lispobj(untag(cell)); - alist_cell = rawcons->car; - cell_tag = fulltag_of(alist_cell); - - if ((cell_tag == fulltag_cons) && - ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) && - (! ref_bit(markbits, car_dnode)) && - (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) && - ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && - (! ref_bit(markbits, car_dnode))) { - *prev = rawcons->cdr; - if (terminatablep) { - rawcons->cdr = termination_list; - termination_list = cell; - } - } else { - set_bit(markbits, dnode); - prev = (LispObj *)(&(rawcons->cdr)); - mark_root(alist_cell); - } - cell = *prev; - } - } - } else { - /* weak list */ - while (! done) { - dnode = gc_area_dnode(cell); - if ((dnode >= GCndnodes_in_area) || - (ref_bit(markbits, dnode))) { - done = true; - } else { - /* Cons cell is unmarked. */ - LispObj thecar; - unsigned cartag; - - rawcons = (cons *) ptr_from_lispobj(untag(cell)); - thecar = rawcons->car; - cartag = fulltag_of(thecar); - - if (is_node_fulltag(cartag) && - ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && - (! ref_bit(markbits, car_dnode))) { - *prev = rawcons->cdr; - if (terminatablep) { - rawcons->cdr = termination_list; - termination_list = cell; - } - } else { - set_bit(markbits, dnode); - prev = (LispObj *)(&(rawcons->cdr)); - } - cell = *prev; - } - } - } - - if (terminatablep) { - deref(weakv,1+3) = termination_list; - if (termination_list != lisp_nil) { - deref(weakv,1) = GCweakvll; - GCweakvll = weakv; - } - } -} - -/* - Screw: doesn't deal with finalization. - */ - -void -reaphashv(LispObj hashv) -{ - hash_table_vector_header - *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv)); - natural - dnode, - npairs = (header_element_count(hashp->header) - - ((sizeof(hash_table_vector_header)/sizeof(LispObj)) -1)) >> 1; - LispObj *pairp = (LispObj*) (hashp+1), weakelement; - Boolean - weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); - bitvector markbits = GCmarkbits; - int tag; - - while (npairs--) { - if (weak_on_value) { - weakelement = pairp[1]; - } else { - weakelement = pairp[0]; - } - tag = fulltag_of(weakelement); - if (is_node_fulltag(tag)) { - dnode = gc_area_dnode(weakelement); - if ((dnode < GCndnodes_in_area) && - ! ref_bit(markbits, dnode)) { - pairp[0] = slot_unbound; - pairp[1] = lisp_nil; - hashp->weak_deletions_count += (1<flags, key_dnode, val_dnode; - Boolean - marked_new = false, - key_marked, - val_marked, - weak_value = ((flags & nhash_weak_value_mask) != 0); - int - skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1, - key_tag, - val_tag, - i; - LispObj - *pairp = (LispObj*) (hashp+1), - key, - val; - - /* Mark everything in the header */ - - for (i = 2; i<= skip; i++) { - mark_root(deref(ptr_to_lispobj(hashp),i)); - } - - elements -= skip; - - for (i = 0; i> population_termination_bit) { - elements -= 1; - } - for(alist = deref(weak_alist, elements); - (fulltag_of(alist) == fulltag_cons) && - ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) && - (! ref_bit(markbits,dnode)); - alist = cdr(alist)) { - pair = car(alist); - pair_tag = fulltag_of(pair); - if ((is_node_fulltag(pair_tag)) && - ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) && - (! ref_bit(markbits,dnode))) { - if (pair_tag == fulltag_cons) { - key = car(pair); - if ((! is_node_fulltag(fulltag_of(key))) || - ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) || - ref_bit(markbits,dnode)) { - /* key is marked, mark value if necessary */ - value = cdr(pair); - if (is_node_fulltag(fulltag_of(value)) && - ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) && - (! ref_bit(markbits,dnode))) { - mark_root(value); - marked_new = true; - } - } - } else { - mark_root(pair); - marked_new = true; - } - } - } - return marked_new; -} - -void -markhtabvs() -{ - LispObj this, header, pending; - int subtag; - bitvector markbits = GCmarkbits; - hash_table_vector_header *hashp; - Boolean marked_new; - - do { - pending = (LispObj) NULL; - marked_new = false; - - while (GCweakvll) { - this = GCweakvll; - GCweakvll = deref(this,1); - - header = header_of(this); - subtag = header_subtag(header); - - if (subtag == subtag_weak) { - natural weak_type = deref(this,2); - deref(this,1) = pending; - pending = this; - if ((weak_type & population_type_mask) == population_weak_alist) { - if (mark_weak_alist(this, weak_type)) { - marked_new = true; - } - } - } else if (subtag == subtag_hash_vector) { - natural elements = header_element_count(header), i; - - hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this)); - if (hashp->flags & nhash_weak_mask) { - deref(this,1) = pending; - pending = this; - if (mark_weak_hash_vector(hashp, elements)) { - marked_new = true; - } - } else { - deref(this,1) = (LispObj)NULL; - for (i = 2; i <= elements; i++) { - mark_root(deref(this,i)); - } - } - } else { - Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this); - } - } - - if (marked_new) { - GCweakvll = pending; - } - } while (marked_new); - - /* Now, everything's marked that's going to be, and "pending" is a list - of populations and weak hash tables. CDR down that list and free - anything that isn't marked. - */ - - while (pending) { - this = pending; - pending = deref(this,1); - deref(this,1) = (LispObj)NULL; - - subtag = header_subtag(header_of(this)); - if (subtag == subtag_weak) { - reapweakv(this); - } else { - reaphashv(this); - } - } - - /* Finally, mark the termination lists in all terminatable weak vectors - They are now linked together on GCweakvll. - This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, - but it will force terminatable popualations to hold on to each other - (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). - */ - pending = GCweakvll; - GCweakvll = (LispObj)NULL; - while (pending) { - this = pending; - pending = deref(this,1); - deref(this,1) = (LispObj)NULL; - mark_root(deref(this,1+3)); - } -} +/* No lisp objects on cstack on x86, at least x86-64 */ +void +mark_cstack_area(area *a) +{ +} + /* Mark the lisp objects in an exception frame */ @@ -1529,176 +1119,10 @@ } -void -mark_tcr_tlb(TCR *tcr) -{ - natural n = tcr->tlb_limit; - LispObj - *start = tcr->tlb_pointer, - *end = (LispObj *) ((BytePtr)start+n), - node; - - while (start < end) { - node = *start; - if (node != no_thread_local_binding_marker) { - mark_root(node); - } - start++; - } -} - -/* - Mark things that're only reachable through some (suspended) TCR. - (This basically means the tcr's gc_context and the exception - frames on its xframe_list.) -*/ - -void -mark_tcr_xframes(TCR *tcr) -{ - xframe_list *xframes; - ExceptionInformation *xp; - - xp = tcr->gc_context; - if (xp) { - mark_xp(xp); - } - - for (xframes = (xframe_list *) tcr->xframe; - xframes; - xframes = xframes->prev) { - mark_xp(xframes->curr); - } -} + -void *postGCptrs = NULL; - -void -postGCfree(void *p) -{ - *(void **)p = postGCptrs; - postGCptrs = p; -} - -void -freeGCptrs() -{ - void *p, *next; - - for (p = postGCptrs; p; p = next) { - next = *((void **)p); - free(p); - } - postGCptrs = NULL; -} - -void -reap_gcable_ptrs() -{ - LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr; - xmacptr_flag flag; - natural dnode; - xmacptr *x; - - while((next = *prev) != (LispObj)NULL) { - dnode = gc_area_dnode(next); - x = (xmacptr *) ptr_from_lispobj(untag(next)); - - if ((dnode >= GCndnodes_in_area) || - (ref_bit(GCmarkbits,dnode))) { - prev = &(x->link); - } else { - *prev = x->link; - flag = (xmacptr_flag)(x->flags); - ptr = x->address; - - if (ptr) { - switch (flag) { - case xmacptr_flag_recursive_lock: - destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr)); - break; - - case xmacptr_flag_ptr: - postGCfree((void *)ptr_from_lispobj(ptr)); - break; - - case xmacptr_flag_rwlock: - break; - - case xmacptr_flag_semaphore: - destroy_semaphore((void**)&(x->address)); - break; - - default: - /* (warn "unknown xmacptr_flag: ~s" flag) */ - /* Unknowd, and perhaps unknowdable. */ - /* Fall in: */ - case xmacptr_flag_none: - break; - } - } - } - } -} - - - -#if WORD_SIZE == 64 -unsigned short *_one_bits = NULL; - -unsigned short -logcount16(unsigned short n) -{ - unsigned short c=0; - - while(n) { - n = n & (n-1); - c++; - } - return c; -} - -void -gc_init() -{ - int i; - - _one_bits = malloc(sizeof(unsigned short) * (1<<16)); - - for (i = 0; i < (1<<16); i++) { - _one_bits[i] = dnode_size*logcount16(i); - } -} - -#define one_bits(x) _one_bits[x] - -#else -const unsigned char _one_bits[256] = { - 0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, - 4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8 -}; - -#define one_bits(x) _one_bits[x] - -void -gc_init() -{ -} - -#endif + + + /* A "pagelet" contains 32 doublewords. The relocation table contains @@ -1841,59 +1265,4 @@ } -LispObj -node_forwarding_address(LispObj node) -{ - int tag_n; - natural dnode = gc_dynamic_area_dnode(node); - - if ((dnode >= GCndynamic_dnodes_in_area) || - (node < GCfirstunmarked)) { - return node; - } - - tag_n = fulltag_of(node); - if (!is_node_fulltag(tag_n)) { - return node; - } - - return dnode_forwarding_address(dnode, tag_n); -} - -Boolean -update_noderef(LispObj *noderef) -{ - LispObj - node = *noderef, - new = node_forwarding_address(node); - - if (new != node) { - *noderef = new; - return true; - } - return false; -} - -void -update_locref(LispObj *locref) -{ - LispObj - obj = *locref, - new = locative_forwarding_address(obj); - - if (new != obj) { - *locref = new; - } -} - -void -forward_gcable_ptrs() -{ - LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; - - while ((next = *prev) != (LispObj)NULL) { - *prev = node_forwarding_address(next); - prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); - } -} void @@ -1974,78 +1343,5 @@ -void -forward_memoized_area(area *a, natural num_memo_dnodes) -{ - bitvector refbits = a->refbits; - LispObj *p = (LispObj *) a->low, x1, x2, new; - natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0; - int tag_x1; - hash_table_vector_header *hashp = NULL; - Boolean header_p; - - if (GCDebug) { - check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); - } - - /* This is pretty straightforward, but we have to note - when we move a key in a hash table vector that wants - us to tell it about that. */ - - set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); - while (memo_dnode < num_memo_dnodes) { - if (bits == 0) { - int remain = nbits_in_word - bitidx; - memo_dnode += remain; - p += (remain+remain); - bits = *++bitsp; - bitidx = 0; - } else { - nextbit = count_leading_zeros(bits); - if ((diff = (nextbit - bitidx)) != 0) { - memo_dnode += diff; - bitidx = nextbit; - p += (diff+diff); - } - x1 = p[0]; - x2 = p[1]; - tag_x1 = fulltag_of(x1); - bits &= ~(BIT0_MASK >> bitidx); - header_p = (nodeheader_tag_p(tag_x1)); - - if (header_p && - (header_subtag(x1) == subtag_hash_vector)) { - hashp = (hash_table_vector_header *) p; - if (hashp->flags & nhash_track_keys_mask) { - hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1); - } else { - hashp = NULL; - } - } - - - if (! header_p) { - new = node_forwarding_address(x1); - if (new != x1) { - *p = new; - } - } - p++; - - new = node_forwarding_address(x2); - if (new != x2) { - *p = new; - if (memo_dnode < hash_dnode_limit) { - hashp->flags |= nhash_key_moved_mask; - hash_dnode_limit = 0; - hashp = NULL; - } - } - p++; - memo_dnode++; - bitidx++; - - } - } -} + @@ -2080,4 +1376,10 @@ forward_headerless_range(p, q); +} + +/* Nothing of interest on x86 cstack */ +void +forward_cstack_area(area *a) +{ } @@ -2102,21 +1404,4 @@ } -void -forward_tcr_tlb(TCR *tcr) -{ - natural n = tcr->tlb_limit; - LispObj - *start = tcr->tlb_pointer, - *end = (LispObj *) ((BytePtr)start+n), - node; - - while (start < end) { - node = *start; - if (node != no_thread_local_binding_marker) { - update_noderef(start); - } - start++; - } -} void @@ -2135,51 +1420,5 @@ } -void -forward_and_resolve_static_references(area *a) -{ - natural - nstatic = static_dnodes_for_area(a), - nstatic_bitmap_words = nstatic >> bitmap_shift; - if (nstatic != 0) { - /* exploit the fact that a cons is the same size as a dnode. */ - cons *pagelet_start = (cons *) a->low, *work; - bitvector markbits = GCmarkbits, - usedbits = tenured_area->static_used; - natural marked, used, used_but_not_marked, ndeleted = 0, i; - - while (nstatic_bitmap_words--) { - marked = *markbits++; - used = *usedbits; - if (marked != used) { - *usedbits = marked; - } - used |= marked; - used_but_not_marked = used & ~marked; - - while (marked) { - i = count_leading_zeros(marked); - marked &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - update_noderef(&work->cdr); - update_noderef(&work->car); - } - - while (used_but_not_marked) { - i = count_leading_zeros(used_but_not_marked); - used_but_not_marked &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - if ((work->cdr != undefined) && - (work->cdr != slot_unbound)) { - work->car = slot_unbound; - work->cdr = slot_unbound; - ndeleted++; - } - } - usedbits++; - pagelet_start += nbits_in_word; - } - lisp_global(DELETED_STATIC_PAIRS) += box_fixnum(ndeleted); - } -} + @@ -2348,412 +1587,6 @@ -Boolean -youngest_non_null_area_p (area *a) -{ - if (a->active == a->high) { - return false; - } else { - for (a = a->younger; a; a = a->younger) { - if (a->active != a->high) { - return false; - } - } - }; - return true; -} - -Boolean just_purified_p = false; - - -/* - All thread's stack areas have been "normalized", as - has the dynamic heap. (The "active" pointer in these areas - matches the stack pointer/freeptr value at the time that - the exception occurred.) -*/ - - -#define get_time(when) gettimeofday(&when, NULL) - - - -#ifdef FORCE_DWS_MARK -#warning recursive marker disabled for testing; remember to re-enable it -#endif - -void -gc(TCR *tcr, signed_natural param) -{ - xframe_list *xframes = (tcr->xframe); - struct timeval start, stop; - area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; - unsigned timeidx = 1; - xframe_list *x; - LispObj - pkg, - itabvec = 0; - BytePtr oldfree = a->active; - TCR *other_tcr; - natural static_dnodes; - -#ifndef FORCE_DWS_MARK - if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { - GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; - } else { - GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size; - } -#else - GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; -#endif - - GCephemeral_low = lisp_global(OLDEST_EPHEMERAL); - if (GCephemeral_low) { - GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low); - } else { - GCn_ephemeral_dnodes = 0; - } - - if (GCn_ephemeral_dnodes) { - GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0); - } else { - GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0); - } - - if (GCephemeral_low) { - if ((oldfree-g1_area->low) < g1_area->threshold) { - to = g1_area; - note = a; - timeidx = 4; - } else if ((oldfree-g2_area->low) < g2_area->threshold) { - to = g2_area; - from = g1_area; - note = g1_area; - timeidx = 3; - } else { - to = tenured_area; - from = g2_area; - note = g2_area; - timeidx = 2; - } - } else { - note = tenured_area; - } - - if (GCverbose) { - char buf[16]; - - comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift); - if (GCephemeral_low) { - fprintf(stderr, - "\n\n;;; Starting EGC of generation %d", - (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); - } else { - fprintf(stderr,"\n\n;;; Starting full GC"); - } - fprintf(stderr, ", %s bytes allocated.\n", buf); - } - - - get_time(start); - lisp_global(IN_GC) = (1<markbits; - GCarealow = ptr_to_lispobj(a->low); - GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift); - GCndnodes_in_area = gc_area_dnode(oldfree); - - if (GCndnodes_in_area) { - GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes; - GCdynamic_markbits = - GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift); - - zero_bits(GCmarkbits, GCndnodes_in_area); - GCweakvll = (LispObj)NULL; - - - if (GCn_ephemeral_dnodes == 0) { - /* For GCTWA, mark the internal package hash table vector of - *PACKAGE*, but don't mark its contents. */ - { - LispObj - itab; - natural - dnode, ndnodes; - - pkg = nrs_PACKAGE.vcell; - if ((fulltag_of(pkg) == fulltag_misc) && - (header_subtag(header_of(pkg)) == subtag_package)) { - itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab; - itabvec = car(itab); - dnode = gc_area_dnode(itabvec); - if (dnode < GCndnodes_in_area) { - ndnodes = (header_element_count(header_of(itabvec))+1) >> 1; - set_n_bits(GCmarkbits, dnode, ndnodes); - } - } - } - } - - { - area *next_area; - area_code code; - - /* Could make a jump table instead of the typecase */ - - for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - mark_tstack_area(next_area); - break; - - case AREA_VSTACK: - mark_vstack_area(next_area); - break; - - case AREA_STATIC: - case AREA_DYNAMIC: /* some heap that isn't "the" heap */ - /* In both of these cases, we -could- use the area's "markbits" - bitvector as a reference map. It's safe (but slower) to - ignore that map and process the entire area. - */ - if (next_area->younger == NULL) { - mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active); - } - break; - - default: - break; - } - } - } - - if (lisp_global(OLDEST_EPHEMERAL)) { - mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low)); - } - - other_tcr = tcr; - do { - mark_tcr_xframes(other_tcr); - mark_tcr_tlb(other_tcr); - other_tcr = other_tcr->next; - } while (other_tcr != tcr); - - - - - /* Go back through *package*'s internal symbols, marking - any that aren't worthless. - */ - - if (itabvec) { - natural - i, - n = header_element_count(header_of(itabvec)); - LispObj - sym, - *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); - - for (i = 0; i < n; i++) { - sym = *raw++; - if (fulltag_of(sym) == fulltag_symbol) { - lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); - natural dnode = gc_area_dnode(sym); - - if ((dnode < GCndnodes_in_area) && - (!ref_bit(GCmarkbits,dnode))) { - /* Symbol is in GC area, not marked. - Mark it if fboundp, boundp, or if - it has a plist or another home package. - */ - - if (FBOUNDP(rawsym) || - BOUNDP(rawsym) || - (rawsym->flags != 0) || /* SPECIAL, etc. */ - (rawsym->plist != lisp_nil) || - ((rawsym->package_predicate != pkg) && - (rawsym->package_predicate != lisp_nil))) { - mark_root(sym); - } - } - } - } - } - - (void)markhtabvs(); - - if (itabvec) { - natural - i, - n = header_element_count(header_of(itabvec)); - LispObj - sym, - *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); - - for (i = 0; i < n; i++, raw++) { - sym = *raw; - if (fulltag_of(sym) == fulltag_symbol) { - lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); - natural dnode = gc_area_dnode(sym); - - if ((dnode < GCndnodes_in_area) && - (!ref_bit(GCmarkbits,dnode))) { - *raw = unbound_marker; - } - } - } - } - - reap_gcable_ptrs(); - - GCrelocptr = global_reloctab; - GCfirstunmarked = calculate_relocation(); - - forward_range((LispObj *) ptr_from_lispobj(GCareadynamiclow), (LispObj *) ptr_from_lispobj(GCfirstunmarked)); - - other_tcr = tcr; - do { - forward_tcr_xframes(other_tcr); - forward_tcr_tlb(other_tcr); - other_tcr = other_tcr->next; - } while (other_tcr != tcr); - - - forward_gcable_ptrs(); - - - - { - area *next_area; - area_code code; - - /* Could make a jump table instead of the typecase */ - - for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - forward_tstack_area(next_area); - break; - - case AREA_VSTACK: - forward_vstack_area(next_area); - break; - - - case AREA_STATIC: - case AREA_DYNAMIC: /* some heap that isn't "the" heap */ - if (next_area->younger == NULL) { - forward_range((LispObj *) next_area->low, (LispObj *) next_area->active); - } - break; - - default: - break; - } - } - } - - if (GCephemeral_low) { - forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); - } else { - /* Full GC, need to process static space */ - forward_and_resolve_static_references(a); - } - - a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap()); - if (to) { - tenure_to_area(to); - } - - zero_memory_range(a->active, oldfree); - - resize_dynamic_heap(a->active, - (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0); - - /* - If the EGC is enabled: If there's no room for the youngest - generation, untenure everything. If this was a full GC and - there's now room for the youngest generation, tenure everything. - */ - if (a->older != NULL) { - natural nfree = (a->high - a->active); - - - if (nfree < a->threshold) { - untenure_from_area(tenured_area); - } else { - if (GCephemeral_low == 0) { - tenure_to_area(tenured_area); - } - } - } - } - lisp_global(GC_NUM) += (1<gccount += (1<vcell; - if ((fulltag_of(val) == fulltag_misc) && - (header_subtag(header_of(val)) == subtag_macptr)) { - timersub(&stop, &start, &elapsed); - timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address); - timeradd(timeinfo, &elapsed, timeinfo); - timeradd(timeinfo+timeidx, &elapsed, timeinfo+timeidx); - } - - val = total_bytes_freed->vcell; - if ((fulltag_of(val) == fulltag_misc) && - (header_subtag(header_of(val)) == subtag_macptr)) { - long long justfreed = oldfree - a->active; - *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed; - if (GCverbose) { - char buf[16]; - if (justfreed <= heap_segment_size) { - justfreed = 0; - } - comma_output_decimal(buf,16,justfreed); - if (note == tenured_area) { - fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec); - } else { - fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", - (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, - buf, - elapsed.tv_sec, elapsed.tv_usec); - } - } - } - } -} + + @@ -3498,5 +2331,5 @@ } a->active += n; - bcopy(ro_base, oldfree, n); + memmove(oldfree, ro_base, n); munmap((void *)ro_base, n); a->ndnodes = area_dnode(a, a->active); @@ -3518,734 +2351,2 @@ return -1; } - - -void -adjust_locref(LispObj *loc, LispObj base, LispObj limit, signed_natural delta) -{ - LispObj p = *loc; - - if (area_dnode(p, base) < limit) { - *loc = p+delta; - } -} - -/* like adjust_locref() above, but only changes the contents of LOC if it's - a tagged lisp pointer */ -void -adjust_noderef(LispObj *loc, LispObj base, LispObj limit, signed_natural delta) -{ - LispObj p = *loc; - int tag_n = fulltag_of(p); - - if (is_node_fulltag(tag_n)) { - if (area_dnode(p, base) < limit) { - *loc = p+delta; - } - } -} - -/* - If *loc is a tagged pointer into the address range denoted by BASE and LIMIT, - nuke it (set it to NIL.) -*/ -void -nuke_noderef(LispObj *loc, LispObj base, LispObj limit) -{ - LispObj p = *loc; - int tag_n = fulltag_of(p); - - if (is_node_fulltag(tag_n)) { - if (area_dnode(p, base) < limit) { - *loc = lisp_nil; - } - } -} - - -void -adjust_pointers_in_xp(ExceptionInformation *xp, - LispObj base, - LispObj limit, - signed_natural delta) -{ - natural *regs = (natural *) xpGPRvector(xp); - - adjust_noderef((LispObj *) (&(regs[Iarg_z])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Iarg_y])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Iarg_x])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Isave3])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Isave2])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Isave1])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Isave0])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Ifn])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Itemp0])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Itemp1])),base,limit,delta); - adjust_noderef((LispObj *) (&(regs[Itemp2])),base,limit,delta); - adjust_locref((LispObj *) (&(xpPC(xp))),base,limit,delta); -} - -void -nuke_pointers_in_xp(ExceptionInformation *xp, - LispObj base, - LispObj limit) -{ - natural *regs = (natural *) xpGPRvector(xp); - - nuke_noderef((LispObj *) (&(regs[Iarg_z])),base,limit); - nuke_noderef((LispObj *) (&(regs[Iarg_y])),base,limit); - nuke_noderef((LispObj *) (&(regs[Iarg_x])),base,limit); - nuke_noderef((LispObj *) (&(regs[Isave3])),base,limit); - nuke_noderef((LispObj *) (&(regs[Isave2])),base,limit); - nuke_noderef((LispObj *) (&(regs[Isave1])),base,limit); - nuke_noderef((LispObj *) (&(regs[Isave0])),base,limit); - nuke_noderef((LispObj *) (&(regs[Ifn])),base,limit); - nuke_noderef((LispObj *) (&(regs[Itemp0])),base,limit); - nuke_noderef((LispObj *) (&(regs[Itemp1])),base,limit); - nuke_noderef((LispObj *) (&(regs[Itemp2])),base,limit); - -} - -void -adjust_pointers_in_headerless_range(LispObj *range_start, - LispObj *range_end, - LispObj base, - LispObj limit, - signed_natural delta) -{ - LispObj *p = range_start; - - while (p < range_end) { - adjust_noderef(p, base, limit, delta); - p++; - } -} - - -void -adjust_pointers_in_range(LispObj *range_start, - LispObj *range_end, - LispObj base, - LispObj limit, - signed_natural delta) -{ - LispObj *p = range_start, node, new; - int tag_n; - natural nwords; - hash_table_vector_header *hashp; - - while (p < range_end) { - node = *p; - tag_n = fulltag_of(node); - if (immheader_tag_p(tag_n)) { - p = (LispObj *) skip_over_ivector((natural) p, node); - } else if (nodeheader_tag_p(tag_n)) { - nwords = header_element_count(node); - nwords += (1 - (nwords&1)); - if ((header_subtag(node) == subtag_hash_vector) && - ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { - hashp = (hash_table_vector_header *) p; - hashp->flags |= nhash_key_moved_mask; - } else if (header_subtag(node) == subtag_function) { - int skip = (int)(p[1]); - p += skip; - nwords -= skip; - } - p++; - while (nwords--) { - adjust_noderef(p, base, limit, delta); - p++; - } - } else { - /* just a cons */ - adjust_noderef(p, base, limit, delta); - p++; - adjust_noderef(p, base, limit, delta); - p++; - } - } -} - -void -nuke_pointers_in_headerless_range(LispObj *range_start, - LispObj *range_end, - LispObj base, - LispObj limit) -{ - LispObj *p = range_start; - - while (p < range_end) { - nuke_noderef(p, base, limit); - p++; - } -} - - -void -nuke_pointers_in_range(LispObj *range_start, - LispObj *range_end, - LispObj base, - LispObj limit) -{ - LispObj *p = range_start, node, new; - int tag_n; - natural nwords; - - while (p < range_end) { - node = *p; - tag_n = fulltag_of(node); - if (immheader_tag_p(tag_n)) { - p = (LispObj *) skip_over_ivector((natural) p, node); - } else if (nodeheader_tag_p(tag_n)) { - nwords = header_element_count(node); - nwords += (1 - (nwords&1)); - if (header_subtag(node) == subtag_function) { - int skip = (int)(p[1]); - p += skip; - nwords -= skip; - } - p++; - while (nwords--) { - nuke_noderef(p, base, limit); - p++; - } - } else { - /* just a cons */ - nuke_noderef(p, base, limit); - p++; - nuke_noderef(p, base, limit); - p++; - } - } -} - -void -adjust_pointers_in_tstack_area(area *a, - LispObj base, - LispObj limit, - LispObj delta) -{ - LispObj - *current, - *next, - *start = (LispObj *) a->active, - *end = start, - *area_limit = (LispObj *) (a->high); - - for (current = start; - end != area_limit; - current = next) { - next = ptr_from_lispobj(*current); - end = ((next >= start) && (next < area_limit)) ? next : area_limit; - adjust_pointers_in_range(current+2, end, base, limit, delta); - } -} - -void -nuke_pointers_in_tstack_area(area *a, - LispObj base, - LispObj limit) -{ - LispObj - *current, - *next, - *start = (LispObj *) a->active, - *end = start, - *area_limit = (LispObj *) (a->high); - - for (current = start; - end != area_limit; - current = next) { - next = ptr_from_lispobj(*current); - end = ((next >= start) && (next < area_limit)) ? next : area_limit; - if (current[1] == 0) { - nuke_pointers_in_range(current+2, end, base, limit); - } - } -} - -void -adjust_pointers_in_vstack_area(area *a, - LispObj base, - LispObj limit, - LispObj delta) -{ - LispObj - *p = (LispObj *) a->active, - *q = (LispObj *) a->high; - - adjust_pointers_in_headerless_range(p, q, base, limit, delta); -} - -void -nuke_pointers_in_vstack_area(area *a, - LispObj base, - LispObj limit) -{ - LispObj - *p = (LispObj *) a->active, - *q = (LispObj *) a->high; - - nuke_pointers_in_headerless_range(p, q, base, limit); -} - -#ifdef PPC -void -adjust_pointers_in_cstack_area(area *a, - LispObj base, - LispObj limit, - LispObj delta) -{ - BytePtr - current, - next, - area_limit = a->high, - low = a->low; - - for (current = a->active; (current >= low) && (current < area_limit); current = next) { - next = *((BytePtr *)current); - if (next == NULL) break; - if (((next - current) == sizeof(lisp_frame)) && - (((((lisp_frame *)current)->savefn) == 0) || - (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { - adjust_noderef(&((lisp_frame *) current)->savefn, base, limit, delta); - adjust_locref(&((lisp_frame *) current)->savelr, base, limit, delta); - } - } -} -#endif - - - -void -adjust_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit, signed_natural delta) -{ - TCR *tcr = current; - xframe_list *xframes; - LispObj *tlb_start, *tlb_end; - ExceptionInformation *xp; - - do { - xp = tcr->gc_context; - if (xp) { - adjust_pointers_in_xp(xp, base, limit, delta); - } - for (xframes = (xframe_list *) tcr->xframe; - xframes; - xframes = xframes->prev) { - adjust_pointers_in_xp(xframes->curr, base, limit, delta); - } - adjust_pointers_in_range(tcr->tlb_pointer, - (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit), - base, - limit, - delta); - tcr = tcr->next; - } while (tcr != current); -} - -void -nuke_pointers_in_tcrs(TCR *current, LispObj base, LispObj limit) -{ - TCR *tcr = current; - xframe_list *xframes; - LispObj *tlb_start, *tlb_end; - ExceptionInformation *xp; - - do { - xp = tcr->gc_context; - if (xp) { - nuke_pointers_in_xp(xp, base, limit); - } - for (xframes = (xframe_list *) tcr->xframe; - xframes; - xframes = xframes->prev) { - nuke_pointers_in_xp(xframes->curr, base, limit); - } - nuke_pointers_in_range(tcr->tlb_pointer, - (LispObj *) ((BytePtr)tcr->tlb_pointer+tcr->tlb_limit), - base, - limit); - tcr = tcr->next; - } while (tcr != current); -} - -void -adjust_gcable_ptrs(LispObj base, LispObj limit, signed_natural delta) -{ - /* These need to be special-cased, because xmacptrs are immediate - objects that contain (in their "link" fields") tagged pointers - to other xmacptrs */ - LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; - - while ((next = *prev) != (LispObj)NULL) { - adjust_noderef(prev, base, limit, delta); - if (delta < 0) { - /* Assume that we've already moved things */ - next = *prev; - } - prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); - } -} - - -void -adjust_pointers_in_dynamic_area(area *a, - LispObj base, - LispObj limit, - signed_natural delta) -{ - natural - nstatic = static_dnodes_for_area(a), - nstatic_bitmap_words = nstatic >> bitmap_shift; - LispObj - *low = (LispObj *) (a->low), - *active = (LispObj *) (a->active), - *dynamic_low = low + (2 * nstatic); - - adjust_pointers_in_range(dynamic_low, active, base, limit, delta); - - if (nstatic && (nstatic <= a->ndnodes)) { - cons *pagelet_start = (cons *) a->low, *work; - bitvector usedbits = tenured_area->static_used; - natural used, i; - - while (nstatic_bitmap_words--) { - used = *usedbits++; - - while (used) { - i = count_leading_zeros(used); - used &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - adjust_noderef(&(work->cdr), base, limit, delta); - adjust_noderef(&(work->car), base, limit, delta); - } - pagelet_start += nbits_in_word; - } - } -} - -void -nuke_pointers_in_dynamic_area(area *a, - LispObj base, - LispObj limit) -{ - natural - nstatic = static_dnodes_for_area(a), - nstatic_bitmap_words = nstatic >> bitmap_shift; - LispObj - *low = (LispObj *) (a->low), - *active = (LispObj *) (a->active), - *dynamic_low = low + (2 * nstatic); - - nuke_pointers_in_range(dynamic_low, active, base, limit); - - if (nstatic && (nstatic <= a->ndnodes)) { - cons *pagelet_start = (cons *) a->low, *work; - bitvector usedbits = tenured_area->static_used; - natural used, i; - - while (nstatic_bitmap_words--) { - used = *usedbits++; - - while (used) { - i = count_leading_zeros(used); - used &= ~(BIT0_MASK >> i); - work = pagelet_start+i; - nuke_noderef(&(work->cdr), base, limit); - nuke_noderef(&(work->car), base, limit); - } - pagelet_start += nbits_in_word; - } - } -} - - -void -adjust_all_pointers(LispObj base, LispObj limit, signed_natural delta) -{ - area *next_area; - area_code code; - - for (next_area = active_dynamic_area; - (code = next_area->code) != AREA_VOID; - next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - adjust_pointers_in_tstack_area(next_area, base, limit, delta); - break; - - case AREA_VSTACK: - adjust_pointers_in_vstack_area(next_area, base, limit, delta); - break; - - case AREA_CSTACK: -#ifndef X86 - adjust_pointers_in_cstack_area(next_area, base, limit, delta); -#endif - break; - - case AREA_STATIC: - case AREA_MANAGED_STATIC: - adjust_pointers_in_range((LispObj *) (next_area->low), - (LispObj *) (next_area->active), - base, - limit, - delta); - break; - - case AREA_DYNAMIC: - adjust_pointers_in_dynamic_area(next_area, base, limit, delta); - break; - } - } - adjust_pointers_in_tcrs(get_tcr(false), base, limit, delta); - adjust_gcable_ptrs(base, limit, delta); -} - -void -nuke_all_pointers(LispObj base, LispObj limit) -{ - area *next_area; - area_code code; - - for (next_area = active_dynamic_area; - (code = next_area->code) != AREA_VOID; - next_area = next_area->succ) { - switch (code) { - case AREA_TSTACK: - nuke_pointers_in_tstack_area(next_area, base, limit); - break; - - case AREA_VSTACK: - nuke_pointers_in_vstack_area(next_area, base, limit); - break; - - case AREA_CSTACK: - /* There aren't any "nukable" pointers in a cstack area */ - break; - - case AREA_STATIC: - case AREA_MANAGED_STATIC: - nuke_pointers_in_range((LispObj *) (next_area->low), - (LispObj *) (next_area->active), - base, - limit); - break; - - case AREA_DYNAMIC: - nuke_pointers_in_dynamic_area(next_area, base, limit); - break; - } - } - nuke_pointers_in_tcrs(get_tcr(false), base, limit); -} - -#ifndef MREMAP_MAYMOVE -#define MREMAP_MAYMOVE 1 -#endif - -#if defined(FREEBSD) || defined(SOLARIS) -void * -freebsd_mremap(void *old_address, - size_t old_size, - size_t new_size, - unsigned long flags) -{ - return old_address; -} -#define mremap freebsd_mremap - -#endif - -#ifdef DARWIN -void * -darwin_mremap(void *old_address, - size_t old_size, - size_t new_size, - unsigned long flags) -{ - void *end = (void *) ((char *)old_address+old_size); - - if (old_size == new_size) { - return old_address; - } - if (new_size < old_size) { - munmap(end, old_size-new_size); - return old_address; - } - { - void * new_address = mmap(NULL, - new_size, - PROT_READ|PROT_WRITE, - MAP_PRIVATE | MAP_ANON, - -1, - 0); - if (new_address != MAP_FAILED) { - vm_copy(mach_task_self(), - (vm_address_t)old_address, - old_size, - (vm_address_t)new_address); - munmap(old_address, old_size); - } - return new_address; - } -} - -#define mremap darwin_mremap -#endif - -Boolean -resize_used_bitvector(natural new_dnodes, bitvector *newbits) -{ - natural - old_dnodes = tenured_area->static_dnodes, - old_page_aligned_size = - (align_to_power_of_2((align_to_power_of_2(old_dnodes, log2_nbits_in_word)>>3), - log2_page_size)), - new_page_aligned_size = - (align_to_power_of_2((align_to_power_of_2(new_dnodes, log2_nbits_in_word)>>3), - log2_page_size)); - bitvector old_used = tenured_area->static_used, new_used = NULL; - - if (old_page_aligned_size == new_page_aligned_size) { - *newbits = old_used; - return true; - } - - if (old_used == NULL) { - new_used = (bitvector)mmap(NULL, - new_page_aligned_size, - PROT_READ|PROT_WRITE, - MAP_PRIVATE | MAP_ANON, - -1, - 0); - if (new_used == MAP_FAILED) { - *newbits = NULL; - return false; - } else { - *newbits = new_used; - return true; - } - } - if (new_page_aligned_size == 0) { - munmap((void *)old_used, old_page_aligned_size); - *newbits = NULL; - return true; - } - - /* Have to try to remap the old bitmap. That's implementation-dependent, - and (naturally) Mach sucks, but no one understands how. - */ - new_used = mremap(old_used, - old_page_aligned_size, - new_page_aligned_size, - MREMAP_MAYMOVE); - if (new_used == MAP_FAILED) { - *newbits = NULL; - return false; - } - *newbits = new_used; - return true; -} - - -int -grow_hons_area(signed_natural delta_in_bytes) -{ - bitvector new_used; - area *ada = active_dynamic_area; - natural - delta_in_dnodes = delta_in_bytes >> dnode_shift, - current_static_dnodes = tenured_area->static_dnodes, - new_static_dnodes; - - delta_in_dnodes = align_to_power_of_2(delta_in_dnodes,log2_nbits_in_word); - new_static_dnodes = current_static_dnodes+delta_in_dnodes; - delta_in_bytes = delta_in_dnodes << dnode_shift; - if (grow_dynamic_area((natural) delta_in_bytes)) { - LispObj - base = (LispObj) (ada->low + (current_static_dnodes*dnode_size)), - oldactive = (LispObj) ada->active, - limit = area_dnode(oldactive, base); - if (!resize_used_bitvector(new_static_dnodes, &new_used)) { - shrink_dynamic_area(delta_in_bytes); - return -1; - } - tenured_area->static_used = new_used; - adjust_all_pointers(base, limit, delta_in_bytes); - memmove((void *)(base+delta_in_bytes),(void *)base,oldactive-base); - ada->ndnodes = area_dnode(ada->high, ada->low); - ada->active += delta_in_bytes; - { - LispObj *p; - natural i; - for (p = (LispObj *)(tenured_area->low + (current_static_dnodes << dnode_shift)), i = 0; - i< delta_in_dnodes; - i++ ) { - *p++ = undefined; - *p++ = undefined; - } - tenured_area->static_dnodes += delta_in_dnodes; - - } - return 0; - } - return -1; -} - -int -shrink_hons_area(signed_natural delta_in_bytes) -{ - area *ada = active_dynamic_area; - signed_natural - delta_in_dnodes = delta_in_bytes >> dnode_shift; - natural - current_static_dnodes = tenured_area->static_dnodes, - new_static_dnodes; - LispObj base, limit, oldactive; - bitvector newbits; - - - delta_in_dnodes = -align_to_power_of_2(-delta_in_dnodes,log2_nbits_in_word); - new_static_dnodes = current_static_dnodes+delta_in_dnodes; - delta_in_bytes = delta_in_dnodes << dnode_shift; - oldactive = (LispObj) (ada->active); - - resize_used_bitvector(new_static_dnodes, &newbits); - tenured_area->static_used = newbits; /* redundant */ - - memmove(ada->low+(new_static_dnodes << dnode_shift), - ada->low+(current_static_dnodes << dnode_shift), - oldactive-(natural)(ada->low+(current_static_dnodes << dnode_shift))); - tenured_area->static_dnodes = new_static_dnodes; - ada->active -= -delta_in_bytes; /* delta_in_bytes is negative */ - shrink_dynamic_area(-delta_in_bytes); - - base = (LispObj) (tenured_area->low + - (new_static_dnodes << dnode_shift)); - limit = area_dnode(tenured_area->low + - (current_static_dnodes << dnode_shift), base); - nuke_all_pointers(base, limit); - - base = (LispObj) (tenured_area->low + - (current_static_dnodes << dnode_shift)); - limit = area_dnode(oldactive, base); - adjust_all_pointers(base, limit, delta_in_bytes); - - xMakeDataExecutable(tenured_area->low+(tenured_area->static_dnodes<active-(tenured_area->low+(tenured_area->static_dnodes< 0) { - return grow_hons_area(delta_in_bytes); - } - if (delta_in_bytes < 0) { - return shrink_hons_area(delta_in_bytes); - } - return 0; -} - Index: /branches/event-ide/ccl/lisp-kernel/x86-macros.s =================================================================== --- /branches/event-ide/ccl/lisp-kernel/x86-macros.s (revision 8261) +++ /branches/event-ide/ccl/lisp-kernel/x86-macros.s (revision 8262) @@ -20,26 +20,26 @@ define([ref_global],[ - mov lisp_global($1),$2 + __(mov lisp_global($1),$2) ]) define([set_global],[ - mov $1,lisp_global($2) + __(mov $1,lisp_global($2)) ]) define([ref_nrs_value],[ - mov nrs.$1+symbol.vcell,$2 + __(mov nrs.$1+symbol.vcell,$2) ]) define([set_nrs_value],[ - mov $1,nrs.$2+symbol.vcell + __(mov $1,nrs.$2+symbol.vcell) ]) define([unbox_fixnum],[ - mov $1,$2 - sar [$]fixnumshift,$2 + __(mov $1,$2) + __(sar [$]fixnumshift,$2) ]) define([box_fixnum],[ - imulq [$]fixnumone,$1,$2 + __(imulq [$]fixnumone,$1,$2) ]) @@ -47,53 +47,7 @@ /* box_fixnum, with no effect on flags */ define([box_fixnum_no_flags],[ - leaq (,$1,8),$2 + __(leaq (,$1,8),$2) ]) -define([save_node_regs],[ - push %arg_z - push %arg_y - push %arg_x - push %temp0 - push %temp1 - push %temp2 - push %save0 - push %save1 - push %save2 - push %save3 - push %ra0 - push %fn -]) - -/* This needs to be done before we transition back to the lisp stack */ -/* from the foreign stack. */ - -define([zero_node_regs],[ - xor %fn,%fn - mov %fn,%ra0 - mov %fn,%save3 - mov %fn,%save2 - mov %fn,%save1 - mov %fn,%save0 - mov %fn,%temp2 - mov %fn,%temp1 - mov %fn,%temp0 - mov %fn,%arg_x - mov %fn,%arg_y - mov %fn,arg_z -]) -define([restore_node_regs],[ - pop %fn - pop %ra0 - pop %save3 - pop %save2 - pop %save1 - pop %save0 - pop %temp2 - pop %temp1 - pop %temp0 - pop %arg_x - pop %arg_y - pop %arg_z -]) /* Zero $3 bytes worth of dnodes, starting at offset $2 relative */ @@ -104,6 +58,6 @@ .macro zero_dnodes .if $2 - movapd %fpzero,$1($0) - zero_dnodes $0,$1+dnode_size,$2-dnode_size + __(movapd %fpzero,$1($0)) + __(zero_dnodes $0,$1+dnode_size,$2-dnode_size) .endif .endmacro @@ -111,5 +65,5 @@ .macro zero_dnodes base,disp,nbytes .ifgt \nbytes - movapd %fpzero,\disp(\base) + __(movapd %fpzero,\disp(\base)) zero_dnodes \base,"\disp+dnode_size","\nbytes-dnode_size" .endif @@ -123,10 +77,11 @@ define([TSP_Alloc_Fixed],[ define([TSP_Alloc_Size],[((($1+node_size) & ~(dnode_size-1))+dnode_size)]) - subq [$]TSP_Alloc_Size,%rcontext:tcr.next_tsp - movq %rcontext:tcr.save_tsp,%stack_temp - movq %rcontext:tcr.next_tsp,$2 + __(subq [$]TSP_Alloc_Size,%rcontext:tcr.next_tsp) + __(movq %rcontext:tcr.save_tsp,%stack_temp) + __(movq %rcontext:tcr.next_tsp,$2) zero_dnodes $2,0,TSP_Alloc_Size - movq %stack_temp,($2) - movq $2,%rcontext:tcr.save_tsp + __(movq %stack_temp,($2)) + __(movq %rbp,tsp_frame.save_rbp($2)) + __(movq $2,%rcontext:tcr.save_tsp) undefine([TSP_Alloc_Size]) ]) @@ -138,18 +93,19 @@ new_macro_labels() subq $1,%rcontext:tcr.next_tsp - movq %rcontext:tcr.save_tsp,%stack_temp - movq %rcontext:tcr.next_tsp,$2 - jmp macro_label(test) + __(movq %rcontext:tcr.save_tsp,%stack_temp) + __(movq %rcontext:tcr.next_tsp,$2) + __(jmp macro_label(test)) macro_label(loop): - movapd %fpzero,0($2) - addq $dnode_size,$2 + __(movapd %fpzero,0($2)) + __(addq $dnode_size,$2) macro_label(test): - subq $dnode_size,$1 - jge macro_label(loop) - movq %rcontext:tcr.next_tsp,$2 - movd %stack_temp,$1 - movq $1,($2) - movq $2,%rcontext:tcr.save_tsp - addq $dnode_size,$2 + __(subq $dnode_size,$1) + __(jge macro_label(loop)) + __(movq %rcontext:tcr.next_tsp,$2) + __(movd %stack_temp,$1) + __(movq $1,($2)) + __(movq %rbp,tsp_frame.save_rbp($2)) + __(movq $2,%rcontext:tcr.save_tsp) + __(addq $dnode_size,$2) ]) @@ -158,6 +114,6 @@ define([Allocate_Catch_Frame],[ TSP_Alloc_Fixed(catch_frame.size,$1) - movq [$](catch_frame.element_count<15),1,[ + __(movl [$]$1<