Changeset 12198


Ignore:
Timestamp:
Jun 5, 2009, 2:14:36 AM (10 years ago)
Author:
gz
Message:

Merge with trunk kernel (and a few compiler changes to match): a few bug fixes, a lot of changes for other platforms.

Location:
branches/working-0711/ccl
Files:
50 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/X8632/x8632-backend.lisp

    r11412 r12198  
    285285(pushnew *x8632-backend* *known-backends* :key #'backend-name)
    286286
     287;;; FFI stuff.  The vanilla i386 ABI always returns structures as a
     288;;; hidden first argument.  Some systems (Darwin, FreeBSD) use a
     289;;; variant that returns small (<= 64 bit) structures in registers.
     290
     291;;; A returned structure is passed as a hidden first argument.
     292(defun x8632::record-type-returns-structure-as-first-arg (rtype)
     293  (declare (ignore rtype))
     294  t)
     295
     296;;; All arguments are passed on the stack.
     297(defun x8632::expand-ff-call (callform args
     298                              &key (arg-coerce #'null-coerce-foreign-arg)
     299                              (result-coerce #'null-coerce-foreign-result))
     300  (let* ((result-type-spec (or (car (last args)) :void))
     301         (struct-by-value-p nil)
     302         (result-op nil)
     303         (result-temp nil)
     304         (result-form nil))
     305    (multiple-value-bind (result-type error)
     306        (ignore-errors (parse-foreign-type result-type-spec))
     307      (if error
     308        (setq result-type-spec :void result-type *void-foreign-type*)
     309        (setq args (butlast args)))
     310      (collect ((argforms))
     311        (when (typep result-type 'foreign-record-type)
     312          (setq result-form (pop args))
     313          (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
     314                        *target-ftd*) result-type)
     315            (progn
     316              (setq result-type *void-foreign-type*
     317                    result-type-spec :void)
     318              (argforms :address)
     319              (argforms result-form))
     320            (progn
     321              (ecase (foreign-type-bits result-type)
     322                (8 (setq result-type-spec :unsigned-byte
     323                         result-op '%get-unsigned-byte))
     324                (16 (setq result-type-spec :unsigned-halfword
     325                          result-op '%get-unsigned-word))
     326                (32 (setq result-type-spec :unsigned-fullword
     327                          result-op '%get-unsigned-long))
     328                (64 (setq result-type-spec :unsigned-doubleword
     329                          result-op '%%get-unsigned-longlong)))
     330              (setq result-type (parse-foreign-type result-type-spec))
     331              (setq result-temp (gensym))
     332              (setq struct-by-value-p t))))
     333        (unless (evenp (length args))
     334          (error "~s should be an even-length list of alternating foreign types and values" args))
     335        (do* ((args args (cddr args)))
     336             ((null args))
     337          (let* ((arg-type-spec (car args))
     338                 (arg-value-form (cadr args)))
     339            (if (or (member arg-type-spec *foreign-representation-type-keywords*
     340                            :test #'eq)
     341                    (typep arg-type-spec 'unsigned-byte))
     342              (progn
     343                (argforms arg-type-spec)
     344                (argforms arg-value-form))
     345              (let* ((ftype (parse-foreign-type arg-type-spec))
     346                     (bits (ensure-foreign-type-bits ftype)))
     347                (when (and (typep ftype 'foreign-record-type)
     348                           (eq (foreign-record-type-kind ftype)
     349                               :transparent-union))
     350                  (ensure-foreign-type-bits ftype)
     351                  (setq ftype (foreign-record-field-type
     352                               (car (foreign-record-type-fields ftype)))
     353                        arg-type-spec (foreign-type-to-representation-type
     354                                       ftype)
     355                        bits (ensure-foreign-type-bits ftype)))
     356                (if (typep ftype 'foreign-record-type)
     357                  (argforms (ceiling bits 32))
     358                  (argforms (foreign-type-to-representation-type ftype)))
     359                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
     360        (argforms (foreign-type-to-representation-type result-type))
     361        (let* ((call (funcall result-coerce result-type-spec
     362                              `(,@callform ,@(argforms)))))
     363          (if struct-by-value-p
     364            `(let* ((,result-temp (%null-ptr)))
     365               (declare (dynamic-extent ,result-temp)
     366                        (type macptr ,result-temp))
     367               (%setf-macptr ,result-temp ,result-form)
     368               (setf (,result-op ,result-temp 0)
     369                     ,call))
     370            call))))))
     371
     372;;; Return 8 values:
     373;;; A list of RLET bindings
     374;;; A list of LET* bindings
     375;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
     376;;; A list of initializaton forms for (some) structure args (not used on x8632)
     377;;; A FOREIGN-TYPE representing the "actual" return type.
     378;;; A form which can be used to initialize FP-ARGS-PTR, relative
     379;;;  to STACK-PTR.  (not used on x8632)
     380;;; The byte offset of the foreign return address, relative to STACK-PTR
     381;;; The number of argument bytes pushed on the stack by the caller, or NIL
     382;;;  if this can't be determined. (Only meaningful on Windows.)
     383
     384(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
     385                                          argspecs result-spec
     386                                          struct-result-name)
     387  (declare (ignore fp-args-ptr))
     388  (collect ((lets)
     389            (rlets)
     390            (dynamic-extent-names))
     391    (let* ((rtype (parse-foreign-type result-spec)))
     392      (when (typep rtype 'foreign-record-type)
     393        (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
     394                      *target-ftd*) rtype)
     395          (setq argvars (cons struct-result-name argvars)
     396                argspecs (cons :address argspecs)
     397                rtype *void-foreign-type*)
     398          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
     399      (do* ((argvars argvars (cdr argvars))
     400            (argspecs argspecs (cdr argspecs))
     401            (offset 8))
     402           ((null argvars)
     403            (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4
     404                    (- offset 8)))
     405        (let* ((name (car argvars))
     406               (spec (car argspecs))
     407               (argtype (parse-foreign-type spec))
     408               (bits (require-foreign-type-bits argtype))
     409               (double nil))
     410          (if (typep argtype 'foreign-record-type)
     411            (lets (list name
     412                        `(%inc-ptr ,stack-ptr
     413                                   ,(prog1 offset
     414                                           (incf offset
     415                                                 (* 4 (ceiling bits 32)))))))
     416            (progn
     417              (lets (list name
     418                          `(,
     419                            (ecase (foreign-type-to-representation-type argtype)
     420                              (:single-float '%get-single-float)
     421                              (:double-float (setq double t) '%get-double-float)
     422                              (:signed-doubleword (setq double t)
     423                                                  '%%get-signed-longlong)
     424                              (:signed-fullword '%get-signed-long)
     425                              (:signed-halfword '%get-signed-word)
     426                              (:signed-byte '%get-signed-byte)
     427                              (:unsigned-doubleword (setq double t)
     428                                                    '%%get-unsigned-longlong)
     429                              (:unsigned-fullword '%get-unsigned-long)
     430                              (:unsigned-halfword '%get-unsigned-word)
     431                              (:unsigned-byte '%get-unsigned-byte)
     432                              (:address '%get-ptr))
     433                            ,stack-ptr
     434                            ,offset)))
     435              (incf offset 4)
     436              (when double (incf offset 4)))))))))
     437
     438(defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result
     439                                              return-type struct-return-arg)
     440  (declare (ignore fp-args-ptr))
     441  (unless (eq return-type *void-foreign-type*)
     442    (if (typep return-type 'foreign-record-type)
     443      ;; If the struct result is returned via a hidden argument, the
     444      ;; return type would have been mapped to :VOID.  On some
     445      ;; systems, small (<= 64 bits) structs are returned by value,
     446      ;; which we arrange to retrieve here.
     447      (ecase (ensure-foreign-type-bits return-type)
     448        (8 `(setf (%get-unsigned-byte ,stack-ptr -8)
     449                  (%get-unsigned-byte ,struct-return-arg 0)))
     450        (16 `(setf (%get-unsigned-word ,stack-ptr -8)
     451                   (%get-unsigned-word ,struct-return-arg 0)))
     452        (32 `(setf (%get-unsigned-long ,stack-ptr -8)
     453                   (%get-unsigned-long ,struct-return-arg 0)))
     454        (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8)
     455               (%%get-unsigned-longlong ,struct-return-arg 0))))
     456      (let* ((return-type-keyword (foreign-type-to-representation-type
     457                                   return-type)))
     458        (collect ((forms))
     459          (forms 'progn)
     460          (case return-type-keyword
     461            (:single-float
     462             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
     463            (:double-float
     464             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
     465          (forms
     466           `(setf (,
     467                   (case return-type-keyword
     468                     (:address '%get-ptr)
     469                     (:signed-doubleword '%%get-signed-longlong)
     470                     (:unsigned-doubleword '%%get-unsigned-longlong)
     471                     (:double-float '%get-double-float)
     472                     (:single-float '%get-single-float)
     473                     (:unsigned-fullword '%get-unsigned-long)
     474                     (t '%get-signed-long)
     475                     ) ,stack-ptr -8) ,result))
     476          (forms))))))
     477
     478
     479
    287480#+x8632-target
    288481(require "X8632-VINSNS")
  • branches/working-0711/ccl/compiler/X86/X8632/x8632-vinsns.lisp

    r11412 r12198  
    847847  (movl (:@ (:%seg :rcontext) x8632::tcr.save-allocptr) (:%l x8632::allocptr))
    848848  (rcmpl (:%l x8632::allocptr) (:@ (:%seg :rcontext) x8632::tcr.save-allocbase))
    849   (jg :no-trap)
     849  (ja :no-trap)
    850850  (uuo-alloc)
    851851  :no-trap
     
    11371137  (movl (:@ (:%seg :rcontext) x8632::tcr.save-allocptr) (:%l freeptr))
    11381138  (rcmpl (:%l freeptr) (:@ (:%seg :rcontext) x8632::tcr.save-allocbase))
    1139   (jg :no-trap)
     1139  (ja :no-trap)
    11401140  (uuo-alloc)
    11411141  :no-trap
  • branches/working-0711/ccl/compiler/X86/X8664/x8664-vinsns.lisp

    r11412 r12198  
    962962  (movq (:rcontext x8664::tcr.save-allocptr) (:%q x8664::allocptr))
    963963  (rcmpq (:%q x8664::allocptr) (:rcontext x8664::tcr.save-allocbase))
    964   (:byte #x7f) (:byte #x02) ;(jg :no-trap)
     964  (:byte #x77) (:byte #x02) ;(ja :no-trap)
    965965  (uuo-alloc)
    966966  :no-trap
     
    13101310  (movq (:rcontext x8664::tcr.save-allocptr) (:%q freeptr))
    13111311  (rcmpq (:%q freeptr) (:rcontext x8664::tcr.save-allocbase))
    1312   (:byte #x7f) (:byte #x02) ;(jg :no-trap)
     1312  (:byte #x77) (:byte #x02) ;(ja :no-trap)
    13131313  (uuo-alloc)
    13141314  :no-trap
  • branches/working-0711/ccl/compiler/arch.lisp

    r12077 r12198  
    6666(defconstant error-kill 16)
    6767(defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
     68(defconstant error-allocate-list 18)
     69
    6870(eval-when (:compile-toplevel :load-toplevel :execute)
    6971  (defconstant error-type-error 128)
     
    345347(defconstant gc-trap-function-purify 1)
    346348(defconstant gc-trap-function-impurify 2)
     349(defconstant gc-trap-function-flash-freeze 4)
    347350(defconstant gc-trap-function-save-application 8)
    348351(defconstant gc-trap-function-get-lisp-heap-threshold 16)
  • branches/working-0711/ccl/level-0/X86/x86-misc.lisp

    r11482 r12198  
    888888  (movq (% rax) (% arg_z))
    889889  (single-value-return))
     890
     891(defx86lapfunction %augment-static-conses ((head arg_y) (tail arg_z))
     892  @again
     893  (movq (@ (+ (target-nil-value) (x8664::kernel-global static-conses))) (% rax))
     894  (movq (% rax) (@ target::cons.cdr (% tail)))
     895  (lock)
     896  (cmpxchgq (% head) (@ (+ (target-nil-value) (x8664::kernel-global static-conses))))
     897  (jnz @again)
     898  @lose
     899  (movl ($ (target-nil-value)) (% arg_z.l))
     900  (single-value-return))
    890901 
    891902(defx86lapfunction %staticp ((x arg_z))
  • branches/working-0711/ccl/level-0/X86/x86-utils.lisp

    r11069 r12198  
    211211    (movq (:rcontext x8664::tcr.save-allocptr) (% allocptr))
    212212    (cmpq (:rcontext x8664::tcr.save-allocbase) (% allocptr))
    213     (jg @ok)
     213    (ja @ok)
    214214    (uuo-alloc)
    215215    @ok
     
    435435(defx86lapfunction freeze ()
    436436  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
    437   (movq ($ arch::gc-trap-function-freeze) (% imm0))
     437  (movl ($ arch::gc-trap-function-freeze) (% imm0.l))
    438438  (uuo-gc-trap)
    439439  (jmp-subprim .SPmakeu64))
    440440
    441  
     441(defx86lapfunction flash-freeze ()
     442  "Like FREEZE, without the GC."
     443  (movl ($ arch::gc-trap-function-flash-freeze) (% imm0.l))
     444  (uuo-gc-trap)
     445  (jmp-subprim .SPmakeu64))
     446
     447(defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
     448  (check-nargs 2)
     449  (save-simple-frame)
     450  (ud2a)
     451  (:byte 10)
     452  (push (% arg_z))
     453  (push (% allocptr))
     454  (set-nargs 2)
     455  (jmp-subprim .SPnvalret))
     456
    442457 
    443458
  • branches/working-0711/ccl/level-0/l0-aprims.lisp

    r10972 r12198  
    155155    (or (%svref r target::lock.whostate-cell)
    156156        (setf (%svref r target::lock.whostate-cell)
    157               (format nil "Lock ~s wait" r)))
     157              (%lock-whostate-string "Lock wait" r)))
    158158    (report-bad-arg r 'recursive-lock)))
    159159
     
    175175    (or (%svref rw target::lock.whostate-cell)
    176176        (setf (%svref rw target::lock.whostate-cell)
    177               (format nil "Read lock ~s wait" rw)))
     177              (%lock-whostate-string "Read lock wait" rw)))
    178178    (report-bad-arg rw 'read-write-lock)))
    179179
     
    183183    (or (%svref rw target::lock.whostate-2-cell)
    184184        (setf (%svref rw target::lock.whostate-2-cell)
    185               (format nil "Read lock ~s wait" rw)))
     185              (%lock-whostate-string "Write lock wait" rw)))
    186186    (report-bad-arg rw 'read-write-lock)))
    187187 
     
    214214    (report-bad-arg size '(and fixnum unsigned-byte)))
    215215  (locally (declare (fixnum size))
    216     (do* ((result '() (cons initial-element result)))
    217         ((zerop size) result)
    218       (decf size))))
     216    (if (>= size (ash 1 16))
     217      (values (%allocate-list initial-element size))
     218      (do* ((result '() (cons initial-element result)))
     219           ((zerop size) result)
     220        (decf size)))))
    219221
    220222; end
  • branches/working-0711/ccl/level-1/l1-callbacks.lisp

    r11267 r12198  
    2323
    2424;;; (defcallback ...) expands into a call to this function.
    25 (defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) (info 0) &aux name trampoline)
     25(defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) info &aux name trampoline)
    2626  (unless (functionp lisp-function)
    2727    (setq lisp-function (require-type lisp-function 'function)))
     
    5858                       (unless (%svref %pascal-functions% i)
    5959                         (return i)))))
    60           (setq trampoline (make-callback-trampoline index (or info 0)))
     60          (setq trampoline (make-callback-trampoline index info))
    6161          (setf (%svref %pascal-functions% index)
    6262                (%cons-pfe trampoline info lisp-function name without-interrupts)))))
  • branches/working-0711/ccl/level-1/l1-pathnames.lisp

    r11650 r12198  
    2525
    2626(defun heap-image-name ()
    27   (let* ((p (%null-ptr)))
     27  (let* ((p (%null-ptr))
     28         (string (%get-utf-8-cstring (%get-kernel-global-ptr 'image-name p))))
    2829    (declare (dynamic-extent p))
    29     #-windows-target
    30     (%get-cstring (%get-kernel-global-ptr 'image-name p))
    31     #+windows-target
    32      (nbackslash-to-forward-slash
    33       (%get-cstring (%get-kernel-global-ptr 'image-name p)))))
     30    #+windows-target (nbackslash-to-forward-slash string)
     31    #+darwin-target (precompose-simple-string string)
     32    #-(or windows-target darwin-target) string))
    3433
    3534(defloadvar *heap-image-name* (heap-image-name))
     
    4443         ((%null-ptr-p arg) (nreverse res))
    4544      (declare (fixnum i))
    46       (push (%get-cstring arg) res))))
     45      (push (%get-utf-8-cstring arg) res))))
    4746
    4847;These are used by make-pathname
  • branches/working-0711/ccl/level-1/x86-callback-support.lisp

    r11267 r12198  
    1919
    2020#+x8664-target 
    21 (defun make-callback-trampoline (index &optional discard-stack-bytes)
    22   (declare (ignore discard-stack-bytes))
     21(defun make-callback-trampoline (index &optional info)
     22  (declare (ignore info))
    2323  (let* ((p (%allocate-callback-pointer 16))
    2424         (addr #.(subprim-name->offset '.SPcallback)))
     
    4040         
    4141#+x8632-target         
    42 (defun make-callback-trampoline (index &optional (discard-stack-bytes 0))
     42(defun make-callback-trampoline (index &optional info)
    4343  (let* ((p (%allocate-callback-pointer 12))
    4444         (addr #.(subprim-name->offset '.SPcallback)))
     45    ;; If the optional info parameter is supplied, it will contain
     46    ;; some stuff in bits 23 through 31.
     47    ;;
     48    ;; If bit 23 is set, that indicates that the caller will pass a
     49    ;; "hidden" argument which is a pointer to appropriate storage for
     50    ;; holding a returned structure.  .SPcallback will have to discard
     51    ;; this extra argument upon return.
     52    ;;
     53    ;; The high 8 bits denote the number of words that .SPcallback
     54    ;; will have to discard upon return (used for _stdcall on
     55    ;; Windows).  Bit 23 won't be set in this case: we will have
     56    ;; already added in the extra word to discard if that's necessary.
     57    ;;
     58    ;; These bits are be packed into the value that .SPcallback
     59    ;; receives in %eax.  Bits 0 through 22 are the callback index.
     60    (if info
     61      (setf (ldb (byte 23 0) info) index)
     62      (setq info index))
    4563    (setf (%get-unsigned-byte p 0) #xb8 ; movl $n,%eax
    46           (%get-unsigned-byte p 1) (ldb (byte 8 0) index)
    47           (%get-unsigned-byte p 2) (ldb (byte 8 8) index)
    48           (%get-unsigned-byte p 3) (ldb (byte 8 16) index)
    49           (%get-unsigned-byte p 4) (ldb (byte 8 0) (ash (or discard-stack-bytes 0) (- x8632::word-shift)))
     64          (%get-unsigned-byte p 1) (ldb (byte 8 0) info)
     65          (%get-unsigned-byte p 2) (ldb (byte 8 8) info)
     66          (%get-unsigned-byte p 3) (ldb (byte 8 16) info)
     67          (%get-unsigned-byte p 4) (ldb (byte 8 24) info)
    5068          (%get-unsigned-byte p 5) #xff  ; jmp *
    5169          (%get-unsigned-byte p 6) #x24
  • branches/working-0711/ccl/lib/macros.lisp

    r12158 r12198  
    25752575         (result-type-spec :void)
    25762576         (args args)
    2577          (discard-stack-args nil)
     2577         (discard-stack-args nil)       ;only meaningful on win32
     2578         (discard-hidden-arg nil)       ;only meaningful on x8632
     2579         (info nil)
    25782580         (woi nil)
    25792581         (need-struct-arg)
     
    25852587             (rtype (ignore-errors (parse-foreign-type spec))))
    25862588        (setq need-struct-arg (typep rtype 'foreign-record-type))
     2589        (when need-struct-arg
     2590          (setq discard-hidden-arg
     2591                (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
     2592                          *target-ftd*) rtype)))
    25872593        (if rtype
    25882594          (setq result-type-spec spec args (butlast args))))
     
    26052611          (funcall (ftd-callback-bindings-function *target-ftd*)
    26062612                   stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name)
    2607         (unless num-arg-bytes (setq num-arg-bytes 0))
     2613        ;; x8632 hair
     2614        (when discard-hidden-arg
     2615          (if discard-stack-args
     2616            ;; We already have to discard some number of args, so just
     2617            ;; discard the extra hidden arg while we're at it.
     2618            (incf num-arg-bytes 4)
     2619            ;; Otherwise, indicate that we'll need to discard the
     2620            ;; hidden arg.
     2621            (setq info (ash 1 23))))
     2622        (when discard-stack-args
     2623          (setq info 0)
     2624          ;; put number of words to discard in high-order byte
     2625          (setf (ldb (byte 8 24) info)
     2626                (ash num-arg-bytes (- target::word-shift))))
    26082627        (multiple-value-bind (body decls doc) (parse-body body env t)
    26092628          `(progn
     
    26332652                ,doc
    26342653              ,woi
    2635               ,(if discard-stack-args num-arg-bytes 0))))))))
     2654              ,info)))))))
    26362655
    26372656
  • branches/working-0711/ccl/lib/misc.lisp

    r12092 r12198  
    951951  "Allocates some memory, freezes it and lets it become garbage.
    952952   This will add the memory to the list of free static conses."
    953   (let ((l (make-array (1- (* 2 *static-cons-chunk*)))))
    954     (declare (ignore l))
    955     (freeze))
    956   (gc))
     953  (let* ((nfullgc (full-gccount)))
     954    (multiple-value-bind (head tail)
     955        (%allocate-list 0 *static-cons-chunk*)
     956      (if (eql (full-gccount) nfullgc)
     957        (freeze)
     958        (flash-freeze))
     959      (%augment-static-conses head tail))))
    957960
    958961(defun static-cons (car-value cdr-value)
     
    989992            0))
    990993  name)
     994
     995(defun %lock-whostate-string (string lock)
     996  (with-standard-io-syntax
     997      (format nil "~a for ~a ~@[~a ~]@ #x~x"
     998              string
     999              (%svref lock target::lock.kind-cell)
     1000              (lock-name lock)
     1001              (%ptr-to-int (%svref lock target::lock._value-cell)))))
  • branches/working-0711/ccl/library/parse-ffi.lisp

    r11807 r12198  
    618618
    619619(defun record-global-union (u)
    620   (when *ffi-global-unions*
     620  (when (and *ffi-global-unions* (ffi-union-fields u))
    621621    (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u)))
    622622
    623623(defun record-global-transparent-union (u)
    624   (when *ffi-global-transparent-unions*
     624  (when (and *ffi-global-transparent-unions* (ffi-transparent-union-fields u))
    625625    (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u)))
    626626
     
    654654
    655655(defun record-global-struct (s)
    656   (when *ffi-global-structs*
     656  (when (and *ffi-global-structs* (ffi-struct-fields s))
    657657    (setf (gethash (ffi-struct-reference s) *ffi-global-structs*) s)))
    658658
  • branches/working-0711/ccl/lisp-kernel/gc-common.c

    r11267 r12198  
    639639
    640640void *postGCptrs = NULL;
     641struct xmacptr *user_postGC_macptrs = NULL;
     642
    641643
    642644void
     
    648650
    649651void
     652postGCfreexmacptr(struct xmacptr *p)
     653{
     654  p->class = (LispObj) user_postGC_macptrs;
     655  user_postGC_macptrs = p;
     656}
     657
     658
     659xmacptr_dispose_fn xmacptr_dispose_functions[xmacptr_flag_user_last-xmacptr_flag_user_first];
     660
     661
     662
     663void
    650664freeGCptrs()
    651665{
    652   void *p, *next;
     666  void *p, *next, *addr;
     667  struct xmacptr *x, *xnext;
     668  int i, flags;
     669  xmacptr_dispose_fn dfn;
    653670
    654671  for (p = postGCptrs; p; p = next) {
     
    657674  }
    658675  postGCptrs = NULL;
     676 
     677  for (x = user_postGC_macptrs; x; x = xnext) {
     678    xnext = (xmacptr *) (x->class);;
     679    flags = x->flags - xmacptr_flag_user_first;
     680    dfn = xmacptr_dispose_functions[flags];
     681    addr = (void *) x->address;
     682    x->address = 0;
     683    x->flags = 0;
     684    x->link = 0;
     685    x->class = 0;
     686    if (dfn && addr) {
     687      dfn(addr);
     688    }
     689  }
     690
     691  user_postGC_macptrs = NULL;
     692}
     693
     694int
     695register_xmacptr_dispose_function(void *dfn)
     696{
     697  int i, k;
     698 
     699  for( i = 0, k = xmacptr_flag_user_first; k < xmacptr_flag_user_last; i++, k++) {
     700    if (xmacptr_dispose_functions[i]==NULL) {
     701      xmacptr_dispose_functions[i] = dfn;
     702      return k;
     703    }
     704    if (xmacptr_dispose_functions[i] == dfn) {
     705      return k;
     706    }
     707  }
     708  return 0;
    659709}
    660710
     
    698748
    699749        default:
     750          if ((flag >= xmacptr_flag_user_first) &&
     751              (flag < xmacptr_flag_user_last)) {
     752            set_n_bits(GCmarkbits,dnode,3);
     753            postGCfreexmacptr(x);
     754            break;
     755          }
    700756          /* (warn "unknown xmacptr_flag: ~s" flag) */
    701757          /* Unknowd, and perhaps unknowdable. */
     
    838894{
    839895  LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new;
     896  struct xmacptr **xprev, *xnext, *xnew;
    840897
    841898  while ((next = *prev) != (LispObj)NULL) {
     
    845902    }
    846903    prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link);
     904  }
     905  xprev = &user_postGC_macptrs;
     906  while (xnext = *xprev) {
     907    xnew = (struct xmacptr *)locative_forwarding_address((LispObj)xnext);
     908    if (xnew != xnext) {
     909      *xprev = xnew;
     910    }
     911    xprev = (struct xmacptr **)(&(xnext->class));
    847912  }
    848913}
     
    10881153    comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift);
    10891154    if (GCephemeral_low) {
    1090       fprintf(stderr,
     1155      fprintf(dbgout,
    10911156              "\n\n;;; Starting Ephemeral GC of generation %d",
    10921157              (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0);
    10931158    } else {
    1094       fprintf(stderr,"\n\n;;; Starting full GC");
    1095     }
    1096     fprintf(stderr, ", %s bytes allocated.\n", buf);
     1159      fprintf(dbgout,"\n\n;;; Starting full GC");
     1160    }
     1161    fprintf(dbgout, ", %s bytes allocated.\n", buf);
    10971162  }
    10981163
     
    13971462        comma_output_decimal(buf,16,justfreed);
    13981463        if (note == tenured_area) {
    1399           fprintf(stderr,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
     1464          fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec);
    14001465        } else {
    1401           fprintf(stderr,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n",
     1466          fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n",
    14021467                  (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0,
    14031468                  buf,
    14041469                  elapsed.tv_sec, elapsed.tv_usec);
    14051470        }
    1406         report_paging_info_delta(stderr, &paging_info_start, &paging_info_stop);
    1407       }
    1408     }
    1409   }
    1410 }
     1471        report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop);
     1472      }
     1473    }
     1474  }
     1475}
  • branches/working-0711/ccl/lisp-kernel/gc.h

    r11267 r12198  
    7878void note_memoized_references(ExceptionInformation *,LogicalAddress, LogicalAddress, BytePtr *, BytePtr *);
    7979void gc(TCR *, signed_natural);
    80 int  purify(TCR *, signed_natural);
    81 int impurify(TCR *, signed_natural);
    8280int change_hons_area_size(TCR *, signed_natural);
    8381void delete_protected_area(protected_area_ptr);
     
    138136#define GC_TRAP_FUNCTION_PURIFY 1
    139137#define GC_TRAP_FUNCTION_IMPURIFY 2
     138#define GC_TRAP_FUNCTION_FLASH_FREEZE 4
    140139#define GC_TRAP_FUNCTION_SAVE_APPLICATION 8
    141140
     
    222221void forward_cstack_area(area *);
    223222LispObj compact_dynamic_heap(void);
    224 int purify(TCR *, signed_natural);
    225 int impurify(TCR *, signed_natural);
     223signed_natural purify(TCR *, signed_natural);
     224signed_natural impurify(TCR *, signed_natural);
     225signed_natural gc_like_from_xp(ExceptionInformation *, signed_natural(*fun)(TCR *, signed_natural), signed_natural);
     226
     227
     228typedef enum {
     229  xmacptr_flag_none = 0,        /* Maybe already disposed by Lisp */
     230  xmacptr_flag_recursive_lock,  /* recursive-lock */
     231  xmacptr_flag_ptr,             /* malloc/free */
     232  xmacptr_flag_rwlock,          /* read/write lock */
     233  xmacptr_flag_semaphore,        /* semaphore */
     234  xmacptr_flag_user_first = 8,  /* first user-defined dispose fn */
     235  xmacptr_flag_user_last = 16   /* exclusive upper bound */
     236} xmacptr_flag;
     237
     238
     239typedef void (*xmacptr_dispose_fn)(void *);
     240
     241extern xmacptr_dispose_fn xmacptr_dispose_functions[];
    226242
    227243#endif                          /* __GC_H__ */
  • branches/working-0711/ccl/lisp-kernel/image.c

    r11267 r12198  
    5959      start = (LispObj *)skip_over_ivector((natural)start, w0);
    6060    } else {
     61#ifdef X86
     62      if (header_subtag(w0) == subtag_function) {
    6163#ifdef X8664
    62       if (header_subtag(w0) == subtag_function) {
    63         int skip = (int) start[1];
     64        int skip = ((int) start[1])+1;
     65#else
     66        int skip = ((unsigned short)start[1])+1;
     67        extern void update_self_references(LispObj *);
     68        update_self_references(start);
     69#endif
    6470     
    6571        start += skip;
     
    148154  version = (header->abi_version) & 0xffff;
    149155  if (version < ABI_VERSION_MIN) {
    150     fprintf(stderr, "Heap image is too old for this kernel.\n");
     156    fprintf(dbgout, "Heap image is too old for this kernel.\n");
    151157    return false;
    152158  }
    153159  if (version > ABI_VERSION_MAX) {
    154     fprintf(stderr, "Heap image is too new for this kernel.\n");
     160    fprintf(dbgout, "Heap image is too new for this kernel.\n");
    155161    return false;
    156162  }
    157163  flags = header->flags;
    158164  if (flags != PLATFORM) {
    159     fprintf(stderr, "Heap image was saved for another platform.\n");
     165    fprintf(dbgout, "Heap image was saved for another platform.\n");
    160166    return false;
    161167  }
     
    388394
    389395OSErr
    390 save_application(unsigned fd)
     396save_application(unsigned fd, Boolean egc_was_enabled)
    391397{
    392398  openmcl_image_file_header fh;
     
    449455  prepare_to_write_dynamic_space(active_dynamic_area);
    450456
     457  {
     458    area *g0_area = g1_area->younger;
     459
     460    /* Save GC config */
     461    lisp_global(LISP_HEAP_THRESHOLD) = lisp_heap_gc_threshold;
     462    lisp_global(G0_THRESHOLD) = g0_area->threshold;
     463    lisp_global(G1_THRESHOLD) = g1_area->threshold;
     464    lisp_global(G2_THRESHOLD) = g2_area->threshold;
     465    lisp_global(EGC_ENABLED) = (LispObj)egc_was_enabled;
     466  }
    451467  /*
    452468    lisp_global(GC_NUM) and lisp_global(FWDNUM) are persistent,
     
    460476    case STATIC_CONSES:
    461477    case WEAK_GC_METHOD:
     478    case LISP_HEAP_THRESHOLD:
     479    case EGC_ENABLED:
     480    case G0_THRESHOLD:
     481    case G1_THRESHOLD:
     482    case G2_THRESHOLD:
    462483      break;
    463484    default:
  • branches/working-0711/ccl/lisp-kernel/imports.s

    r11660 r12198  
    5050        defimport(jvm_init)
    5151        defimport(tcr_frame_ptr)
    52         defimport(register_cstack_holding_area_lock)
    53         defimport(raise_thread_interrupt)
     52        defimport(register_xmacptr_dispose_function)
     53        defimport(open_debug_output)
    5454        defimport(get_r_debug)
    5555        defimport(restore_soft_stack_limit)
     
    5757        defimport(lisp_bug)
    5858        defimport(xNewThread)
    59         defimport(xYieldToThread)
     59        defimport(cooperative_thread_startup)
    6060        defimport(xDisposeThread)
    6161        defimport(xThreadCurrentStackSpace)
  • branches/working-0711/ccl/lisp-kernel/lisp-debug.c

    r11949 r12198  
    3434#include <sys/stat.h>
    3535
     36FILE *dbgout = NULL;
    3637
    3738typedef enum {
     
    4243} debug_command_return;
    4344
     45
     46Boolean
     47open_debug_output(int fd)
     48{
     49  FILE *f = fdopen(fd, "w");
     50 
     51  if (f) {
     52    if (setvbuf(f, NULL, _IONBF, 0) == 0) {
     53      dbgout = f;
     54      return true;
     55    }
     56    fclose(f);
     57  }
     58  return false;
     59}
    4460
    4561
     
    6884
    6985Boolean lisp_debugger_in_foreign_code = false;
     86
     87#ifndef WINDOWS
     88Boolean
     89stdin_is_dev_null()
     90{
     91  struct stat fd0stat, devnullstat;
     92
     93  if (fstat(fileno(stdin),&fd0stat)) {
     94    return true;
     95  }
     96  if (stat("/dev/null",&devnullstat)) {
     97    return true;
     98  }
     99  return ((fd0stat.st_ino == devnullstat.st_ino) &&
     100          (fd0stat.st_dev == devnullstat.st_dev));
     101}
     102
     103#endif
    70104
    71105char *
     
    204238
    205239#ifdef PPC
    206   fprintf(stderr, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
     240  fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val));
    207241#endif
    208242#ifdef X8664
    209   fprintf(stderr, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val));
     243  fprintf(dbgout, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val));
    210244#endif
    211245#ifdef X8632
     
    221255      s = print_lisp_object(val);
    222256
    223     fprintf(stderr, "%%%s (%s) = %s\n", Iregnames[r], label, s);
     257    fprintf(dbgout, "%%%s (%s) = %s\n", Iregnames[r], label, s);
    224258  }
    225259#endif
     
    235269  natural dsisr = xpDSISR(xp);
    236270
    237   fprintf(stderr, "%s operation to %s address 0x%lx\n",
     271  fprintf(dbgout, "%s operation to %s address 0x%lx\n",
    238272          dsisr & (1<<25) ? "Write" : "Read",
    239273          dsisr & (1<<27) ? "protected" : "unmapped",
     
    259293      switch (errnum) {
    260294      case error_udf_call:
    261         fprintf(stderr, "ERROR: undefined function call: %s\n",
     295        fprintf(dbgout, "ERROR: undefined function call: %s\n",
    262296                print_lisp_object(xpGPR(xp,fname)));
    263297        described = true;
     
    265299       
    266300      default:
    267         fprintf(stderr, "ERROR: lisp error %d\n", errnum);
     301        fprintf(dbgout, "ERROR: lisp error %d\n", errnum);
    268302        described = true;
    269303        break;
     
    276310  }
    277311  if (!described) {
    278     fprintf(stderr, "Illegal instruction (0x%08x) at 0x%lx\n",
     312    fprintf(dbgout, "Illegal instruction (0x%08x) at 0x%lx\n",
    279313            the_uuo, where);
    280314  }
     
    301335      case TO_NE:
    302336        if (xpGPR(xp, nargs) < D_field(the_trap)) {
    303           fprintf(stderr, "Too few arguments (no opt/rest)\n");
     337          fprintf(dbgout, "Too few arguments (no opt/rest)\n");
    304338        } else {
    305           fprintf(stderr, "Too many arguments (no opt/rest)\n");
     339          fprintf(dbgout, "Too many arguments (no opt/rest)\n");
    306340        }
    307341        identified = true;
     
    309343       
    310344      case TO_GT:
    311         fprintf(stderr, "Event poll !\n");
     345        fprintf(dbgout, "Event poll !\n");
    312346        identified = true;
    313347        break;
    314348       
    315349      case TO_HI:
    316         fprintf(stderr, "Too many arguments (with opt)\n");
     350        fprintf(dbgout, "Too many arguments (with opt)\n");
    317351        identified = true;
    318352        break;
    319353       
    320354      case TO_LT:
    321         fprintf(stderr, "Too few arguments (with opt/rest/key)\n");
     355        fprintf(dbgout, "Too few arguments (with opt/rest/key)\n");
    322356        identified = true;
    323357        break;
     
    354388            ra = RA_field(instr);
    355389            if (lisp_reg_p(ra)) {
    356               fprintf(stderr, "Unbound variable: %s\n",
     390              fprintf(dbgout, "Unbound variable: %s\n",
    357391                      print_lisp_object(xpGPR(xp,ra)));
    358392              identified = true;       
     
    382416            ra = RA_field(instr);
    383417            if (lisp_reg_p(ra)) {
    384               fprintf(stderr, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2);
     418              fprintf(dbgout, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2);
    385419              identified = true;
    386420            }
     
    394428            rs = RS_field(instr);
    395429            if (lisp_reg_p(rs)) {
    396               fprintf(stderr, "value 0x%lX is not of the expected type 0x%02X\n",
     430              fprintf(dbgout, "value 0x%lX is not of the expected type 0x%02X\n",
    397431                      xpGPR(xp, rs), err_arg2);
    398432              identified = true;
     
    413447    case TO_LO:
    414448      if (RA_field(the_trap) == sp) {
    415         fprintf(stderr, "Stack overflow! Run away! Run away!\n");
     449        fprintf(dbgout, "Stack overflow! Run away! Run away!\n");
    416450        identified = true;
    417451      }
     
    425459        ra = RA_field(instr);
    426460        if (lisp_reg_p(ra)) {
    427           fprintf(stderr, "Bad index %d for vector %lX length %d\n",
     461          fprintf(dbgout, "Bad index %d for vector %lX length %d\n",
    428462                  unbox_fixnum(xpGPR(xp, RA_field(the_trap))),
    429463                  xpGPR(xp, ra),
     
    437471
    438472  if (!identified) {
    439     fprintf(stderr, "Unknown trap: 0x%08x\n", the_trap);
     473    fprintf(dbgout, "Unknown trap: 0x%08x\n", the_trap);
    440474  }
    441475
     
    451485    TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext));
    452486
    453     fprintf(stderr, "rcontext = 0x%lX ", xpcontext);
     487    fprintf(dbgout, "rcontext = 0x%lX ", xpcontext);
    454488    if (!active_tcr_p(xpcontext)) {
    455       fprintf(stderr, "(INVALID)\n");
     489      fprintf(dbgout, "(INVALID)\n");
    456490    } else {
    457       fprintf(stderr, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
     491      fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift);
    458492      show_lisp_register(xp, "fn", fn);
    459493      show_lisp_register(xp, "arg_z", arg_z);
     
    480514    show_lisp_register(xp, "arg_y", Iarg_y);
    481515    show_lisp_register(xp, "arg_x", Iarg_x);
    482     fprintf(stderr,"------\n");
     516    fprintf(dbgout,"------\n");
    483517    show_lisp_register(xp, "fn", Ifn);
    484     fprintf(stderr,"------\n");
     518    fprintf(dbgout,"------\n");
    485519    show_lisp_register(xp, "save0", Isave0);
    486520    show_lisp_register(xp, "save1", Isave1);
    487521    show_lisp_register(xp, "save2", Isave2);
    488522    show_lisp_register(xp, "save3", Isave3);
    489     fprintf(stderr,"------\n");
     523    fprintf(dbgout,"------\n");
    490524    show_lisp_register(xp, "temp0", Itemp0);
    491525    show_lisp_register(xp, "temp1", Itemp1);
    492526    show_lisp_register(xp, "temp2", Itemp2);
    493     fprintf(stderr,"------\n");
     527    fprintf(dbgout,"------\n");
    494528    if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
    495       fprintf(stderr,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
    496     }
    497 #endif
    498   }
     529      fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff));
     530    }
     531#endif
    499532
    500533#ifdef X8632
    501534  show_lisp_register(xp, "arg_z", Iarg_z);
    502535  show_lisp_register(xp, "arg_y", Iarg_y);
    503   fprintf(stderr,"------\n");
     536  fprintf(dbgout,"------\n");
    504537  show_lisp_register(xp, "fn", Ifn);
    505   fprintf(stderr,"------\n");
     538  fprintf(dbgout,"------\n");
    506539  show_lisp_register(xp, "temp0", Itemp0);
    507540  show_lisp_register(xp, "temp1", Itemp1);
    508   fprintf(stderr,"------\n");
     541  fprintf(dbgout,"------\n");
    509542  if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) {
    510     fprintf(stderr,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
    511   }
    512 #endif
     543    fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)));
     544  }
     545#endif
     546  }
    513547 
    514548  return debug_continue;
     
    557591{
    558592  static char buf[128];
    559   char *p;
     593  char *p, *res;
    560594
    561595  do {
    562596    fpurge(stdin);
    563     fprintf(stderr, "\n %s :",prompt);
     597    fprintf(dbgout, "\n %s :",prompt);
    564598    buf[0] = 0;
    565     fgets(buf, sizeof(buf)-1, stdin);
     599    res = fgets(buf, sizeof(buf), stdin);
    566600  } while (0);
    567   p = strchr(buf, '\n');
     601  p = strchr(res, '\n');
    568602  if (p) {
    569603    *p = 0;
     
    576610debug_get_natural_value(char *prompt)
    577611{
    578   char s[32];
     612  char s[32], *res;
    579613  int n;
    580614  natural val;
     
    582616  do {
    583617    fpurge(stdin);
    584     fprintf(stderr, "\n  %s :", prompt);
    585     fgets(s, 24, stdin);
     618    fprintf(dbgout, "\n  %s :", prompt);
     619    s[0]=0;
     620    res = fgets(s, 24, stdin);
    586621    n = sscanf(s, "%lu", &val);
    587622  } while (n != 1);
     
    592627debug_get_u5_value(char *prompt)
    593628{
    594   char s[32];
     629  char s[32], *res;
    595630  int n;
    596631  unsigned val;
     
    598633  do {
    599634    fpurge(stdin);
    600     fprintf(stderr, "\n  %s :", prompt);
    601     fgets(s, 24, stdin);
    602     n = sscanf(s, "%i", &val);
     635    fprintf(dbgout, "\n  %s :", prompt);
     636    res = fgets(s, 24, stdin);
     637    n = sscanf(res, "%i", &val);
    603638  } while ((n != 1) || (val > 31));
    604639  return val;
     
    625660    area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area;
    626661
    627     fprintf(stderr, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
    628     fprintf(stderr, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
     662    fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr);
     663    fprintf(dbgout, "Control (C) stack area:  low = 0x" LISP ", high = 0x" LISP "\n",
    629664            (cs_area->low), (cs_area->high));
    630     fprintf(stderr, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
     665    fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n",
    631666            (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high);
    632     fprintf(stderr, "Exception stack pointer = 0x" LISP "\n",
     667    fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n",
    633668#ifdef PPC
    634669            (u64_t) (natural)(xpGPR(xp,1))
     
    663698  int a, b;
    664699  for (a = 0, b = 16; a < 16; a++, b++) {
    665     fprintf(stderr,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
     700    fprintf(dbgout,"r%02d = 0x%016lX    r%02d = 0x%016lX\n",
    666701            a, xpGPR(xp, a),
    667702            b, xpGPR(xp, b));
    668703  }
    669704 
    670   fprintf(stderr, "\n PC = 0x%016lX     LR = 0x%016lX\n",
     705  fprintf(dbgout, "\n PC = 0x%016lX     LR = 0x%016lX\n",
    671706          xpPC(xp), xpLR(xp));
    672   fprintf(stderr, "CTR = 0x%016lX    CCR = 0x%08X\n",
     707  fprintf(dbgout, "CTR = 0x%016lX    CCR = 0x%08X\n",
    673708          xpCTR(xp), xpCCR(xp));
    674   fprintf(stderr, "XER = 0x%08X            MSR = 0x%016lX\n",
     709  fprintf(dbgout, "XER = 0x%08X            MSR = 0x%016lX\n",
    675710          xpXER(xp), xpMSR(xp));
    676   fprintf(stderr,"DAR = 0x%016lX  DSISR = 0x%08X\n",
     711  fprintf(dbgout,"DAR = 0x%016lX  DSISR = 0x%08X\n",
    677712          xpDAR(xp), xpDSISR(xp));
    678713#else
    679714  int a, b, c, d;;
    680715  for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) {
    681     fprintf(stderr,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
     716    fprintf(dbgout,"r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X  r%02d = 0x%08X\n",
    682717            a, xpGPR(xp, a),
    683718            b, xpGPR(xp, b),
     
    685720            d, xpGPR(xp, d));
    686721  }
    687   fprintf(stderr, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
     722  fprintf(dbgout, "\n PC = 0x%08X   LR = 0x%08X  CTR = 0x%08X  CCR = 0x%08X\n",
    688723          xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp));
    689   fprintf(stderr, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
     724  fprintf(dbgout, "XER = 0x%08X  MSR = 0x%08X  DAR = 0x%08X  DSISR = 0x%08X\n",
    690725          xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp));
    691726#endif
     
    693728
    694729#ifdef X8664
    695   fprintf(stderr,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
    696   fprintf(stderr,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
    697   fprintf(stderr,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
    698   fprintf(stderr,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
    699   fprintf(stderr,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
    700   fprintf(stderr,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
    701   fprintf(stderr,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
    702   fprintf(stderr,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
    703   fprintf(stderr,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
     730  fprintf(dbgout,"%%rax = 0x" ZLISP "      %%r8  = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8));
     731  fprintf(dbgout,"%%rcx = 0x" ZLISP "      %%r9  = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9));
     732  fprintf(dbgout,"%%rdx = 0x" ZLISP "      %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10));
     733  fprintf(dbgout,"%%rbx = 0x" ZLISP "      %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11));
     734  fprintf(dbgout,"%%rsp = 0x" ZLISP "      %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12));
     735  fprintf(dbgout,"%%rbp = 0x" ZLISP "      %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13));
     736  fprintf(dbgout,"%%rsi = 0x" ZLISP "      %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14));
     737  fprintf(dbgout,"%%rdi = 0x" ZLISP "      %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15));
     738  fprintf(dbgout,"%%rip = 0x" ZLISP "   %%rflags = 0x%08lx\n",
    704739          xpGPR(xp, Iip), eflags_register(xp));
    705740#endif
    706741
    707742#ifdef X8632
    708   fprintf(stderr, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
    709   fprintf(stderr, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
    710   fprintf(stderr, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
    711   fprintf(stderr, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
    712   fprintf(stderr, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
    713   fprintf(stderr, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
    714   fprintf(stderr, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
    715   fprintf(stderr, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
    716   fprintf(stderr, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
    717   fprintf(stderr, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
     743  unsigned short rcs,rds,res,rfs,rgs,rss;
     744#ifdef DARWIN
     745  rcs = xp->uc_mcontext->__ss.__cs;
     746  rds = xp->uc_mcontext->__ss.__ds;
     747  res = xp->uc_mcontext->__ss.__es;
     748  rfs = xp->uc_mcontext->__ss.__fs;
     749  rgs = xp->uc_mcontext->__ss.__gs;
     750  rss = xp->uc_mcontext->__ss.__ss;
     751#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
     752#endif
     753#ifdef LINUX
     754  rcs = xp->uc_mcontext.gregs[REG_CS];
     755  rds = xp->uc_mcontext.gregs[REG_DS];
     756  res = xp->uc_mcontext.gregs[REG_ES];
     757  rfs = xp->uc_mcontext.gregs[REG_FS];
     758  rgs = xp->uc_mcontext.gregs[REG_GS];
     759  rss = xp->uc_mcontext.gregs[REG_SS];
     760#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
     761#endif
     762#ifdef FREEBSD
     763  rcs = xp->uc_mcontext.mc_cs;
     764  rds = xp->uc_mcontext.mc_ds;
     765  res = xp->uc_mcontext.mc_es;
     766  rfs = xp->uc_mcontext.mc_fs;
     767  rgs = xp->uc_mcontext.mc_gs;
     768  rss = xp->uc_mcontext.mc_ss;
     769#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
     770#endif
     771#ifdef SOLARIS
     772  rcs = xp->uc_mcontext.gregs[CS];
     773  rds = xp->uc_mcontext.gregs[DS];
     774  res = xp->uc_mcontext.gregs[ES];
     775  rfs = xp->uc_mcontext.gregs[FS];
     776  rgs = xp->uc_mcontext.gregs[GS];
     777  rss = xp->uc_mcontext.gregs[SS];
     778#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
     779#endif
     780#ifdef WINDOWS
     781  rcs = xp->SegCs;
     782  rds = xp->SegDs;
     783  res = xp->SegEs;
     784  rfs = xp->SegFs;
     785  rgs = xp->SegGs;
     786  rss = xp->SegSs;
     787#define DEBUG_SHOW_X86_SEGMENT_REGISTERS
     788#endif
     789
     790
     791
     792  fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX));
     793  fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX));
     794  fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX));
     795  fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX));
     796  fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP));
     797  fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP));
     798  fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI));
     799  fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI));
     800  fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP));
     801  fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL));
     802#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS
     803  fprintf(dbgout,"\n");
     804  fprintf(dbgout, "%%cs = 0x%04x\n", rcs);
     805  fprintf(dbgout, "%%ds = 0x%04x\n", rds);
     806  fprintf(dbgout, "%%ss = 0x%04x\n", rss);
     807  fprintf(dbgout, "%%es = 0x%04x\n", res);
     808  fprintf(dbgout, "%%fs = 0x%04x\n", rfs);
     809  fprintf(dbgout, "%%gs = 0x%04x\n", rgs);
     810
     811#endif
     812
    718813#endif
    719814
     
    731826 
    732827  for (i = 0; i < 32; i++, np+=2) {
    733     fprintf(stderr, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
    734   }
    735   fprintf(stderr, "FPSCR = %08X\n", xpFPSCR(xp));
     828    fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i,  np[0], np[1], *dp++);
     829  }
     830  fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp));
    736831#endif
    737832#ifdef X8664
     
    764859    dp = (double *) xmmp;
    765860    np = (int *) xmmp;
    766     fprintf(stderr, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
    767   }
    768   fprintf(stderr, "mxcsr = 0x%08x\n",
     861    fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp);
     862  }
     863  fprintf(dbgout, "mxcsr = 0x%08x\n",
    769864#ifdef LINUX
    770865          xp->uc_mcontext.fpregs->mxcsr
     
    780875#endif
    781876#ifdef WINDOWS
    782           0 /* XXX: get from somewhere */
     877          *(xpMXCSRptr(xp))
    783878#endif
    784879          );
     
    795890    dp = (double *)xmmp;
    796891    np = (int *)xmmp;
    797     fprintf(stderr, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
     892    fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np,
    798893            (double)(*sp), np[1], np[0], *dp);
    799894  }
    800   fprintf(stderr, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
     895  fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr);
    801896#endif
    802897#endif
     
    827922    /* If we have an XP or don't need one, call the function */
    828923    if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) {
    829       fprintf(stderr, "(%c)  %s\n", entry->c, entry->help_text);
     924      fprintf(dbgout, "(%c)  %s\n", entry->c, entry->help_text);
    830925    }
    831926  }
     
    9921087      }
    9931088      if (codev) {
    994         fprintf(stderr, " While executing: %s\n", print_lisp_object(f));
     1089        fprintf(dbgout, " While executing: %s\n", print_lisp_object(f));
    9951090      }
    9961091    } else {
     
    9991094      natural where = (natural)xpPC(xp);
    10001095
    1001       fprintf(stderr, " In foreign code at address 0x" ZLISP "\n", where);
     1096      fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where);
    10021097      foreign_name = foreign_name_and_offset(where, &disp);
    10031098      if (foreign_name) {
    1004         fprintf(stderr, "  [%s + %d]\n", foreign_name, disp);
     1099        fprintf(dbgout, "  [%s + %d]\n", foreign_name, disp);
    10051100      }
    10061101    }
     
    10251120  debug_command_return state = debug_continue;
    10261121
     1122  va_start(args,message);
     1123  vfprintf(dbgout, message, args);
     1124  fprintf(dbgout, "\n");
     1125  va_end(args);
     1126 
     1127
     1128#ifndef WINDOWS
     1129  if (stdin_is_dev_null()) {
     1130    return -1;
     1131  }
     1132#endif
    10271133  if (threads_initialized) {
    10281134    suspend_other_threads(false);
    10291135  }
    10301136
    1031   va_start(args,message);
    1032   vfprintf(stderr, message, args);
    1033   fprintf(stderr, "\n");
    1034   va_end(args);
    1035  
    10361137  lisp_debugger_in_foreign_code = in_foreign_code;
    10371138  if (in_foreign_code) {   
    10381139    char *foreign_name;
    10391140    int disp;
    1040     fprintf(stderr, "Exception occurred while executing foreign code\n");
     1141    fprintf(dbgout, "Exception occurred while executing foreign code\n");
    10411142    foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp);
    10421143    if (foreign_name) {
    1043       fprintf(stderr, " at %s + %d\n", foreign_name, disp);
     1144      fprintf(dbgout, " at %s + %d\n", foreign_name, disp);
    10441145    }
    10451146  }
     
    10531154  if (lisp_global(BATCH_FLAG)) {
    10541155#ifdef WINDOWS
    1055     fprintf(stderr, "Current Process Id %d\n", (int)GetCurrentProcessId());
     1156    fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId());
    10561157#else
    1057     fprintf(stderr, "Main thread pid %d\n", main_thread_pid);
     1158    fprintf(dbgout, "Main thread pid %d\n", main_thread_pid);
    10581159#endif
    10591160    debug_thread_info(xp, info, 0);
     
    10671168  }
    10681169
    1069   fprintf(stderr, "? for help\n");
     1170  fprintf(dbgout, "? for help\n");
    10701171  while (state == debug_continue) {
    10711172#ifdef WINDOWS
    1072     fprintf(stderr, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
     1173    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId());
    10731174#else
    1074     fprintf(stderr, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
     1175    fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid);
    10751176#endif
    10761177    state = apply_debug_command(xp, readc(), info, why);
  • branches/working-0711/ccl/lisp-kernel/lisp-errors.h

    r11164 r12198  
    3535#define error_kill 16
    3636#define error_cant_call 17
     37#define error_allocate_list 18
    3738
    3839#define error_type_error 128
  • branches/working-0711/ccl/lisp-kernel/lisp-exceptions.h

    r10389 r12198  
    124124void Bug(ExceptionInformation *, const char *format_string, ...);
    125125void FBug(ExceptionInformation *, const char *format_string, ...);
    126 int gc_from_xp(ExceptionInformation *, signed_natural);
    127 int purify_from_xp(ExceptionInformation *, signed_natural);
    128 int impurify_from_xp(ExceptionInformation *, signed_natural);
    129 int change_hons_area_size_from_xp(ExceptionInformation *, signed_natural);
     126signed_natural gc_from_xp(ExceptionInformation *, signed_natural);
     127signed_natural purify_from_xp(ExceptionInformation *, signed_natural);
     128signed_natural impurify_from_xp(ExceptionInformation *, signed_natural);
     129
    130130
    131131
  • branches/working-0711/ccl/lisp-kernel/lisp.h

    r11089 r12198  
    119119#define PLATFORM (PLATFORM_OS|PLATFORM_CPU|PLATFORM_WORD_SIZE)
    120120
     121#ifdef WINDOWS
     122Boolean check_for_embedded_image (wchar_t *);
     123#else
    121124Boolean check_for_embedded_image (char *);
     125#endif
    122126natural xStackSpace();
    123127void init_threads(void *, TCR *);
     
    126130void wperror(char *);
    127131#endif
     132
     133#include <stdio.h>
     134
     135extern FILE *dbgout;
  • branches/working-0711/ccl/lisp-kernel/lisp_globals.h

    r11089 r12198  
    4848#define STACK_SIZE (-26)        /* from the command line */
    4949#define OBJC_2_BEGIN_CATCH (-27)  /* address of ObjC 2.0 objc_begin_catch() */
    50 #define BAD_FUNCALL (-28)       /* funcall pseudo-target on x86 */
     50#define KERNEL_PATH (-28)       /* real executable name */
    5151#define ALL_AREAS (-29)         /* doubly-linked list of stack & heap areas */
    5252#define LEXPR_RETURN (-30)      /* magic &lexpr cleanup code */
     
    7171
    7272#define MIN_KERNEL_GLOBAL INITIAL_TCR
     73
     74/* These are only non-zero when an image is being saved or loaded */
     75
     76#if (WORD_SIZE==64)
     77#define LISP_HEAP_THRESHOLD (-511)
     78#define EGC_ENABLED (-510)
     79#define G0_THRESHOLD (-509)
     80#define G1_THRESHOLD (-508)
     81#define G2_THRESHOLD (-507)
     82#else
     83#define LISP_HEAP_THRESHOLD (-1023)
     84#define EGC_ENABLED (-1022)
     85#define G0_THRESHOLD (-1021)
     86#define G1_THRESHOLD (-1020)
     87#define G2_THRESHOLD (-1019)
     88#endif
    7389
    7490#ifdef PPC
  • branches/working-0711/ccl/lisp-kernel/lispdcmd.c

    r137 r12198  
    2727display_buffer(char *buf)
    2828{
    29   fprintf(stderr, "%s\n", buf);
     29  fprintf(dbgout, "%s\n", buf);
    3030}
    3131
  • branches/working-0711/ccl/lisp-kernel/memory.c

    r11089 r12198  
    178178                       PAGE_NOACCESS);
    179179  if (!start) {
    180     fprintf(stderr, "Can't get desired heap address at 0x" LISP "\n", want);
     180#if DEBUG_MEMORY   
     181    fprintf(dbgout, "Can't get desired heap address at 0x" LISP "\n", want);
     182#endif
    181183    start = VirtualAlloc(0,
    182184                         totalsize + heap_segment_size,
     
    184186                         PAGE_NOACCESS);
    185187    if (!start) {
    186       wperror("VirtualAlloc");
    187188      return NULL;
    188189    }
     
    196197               0);
    197198  if (start == MAP_FAILED) {
    198     perror("Initial mmap");
    199199    return NULL;
    200200  }
     
    210210#endif
    211211#if DEBUG_MEMORY
    212   fprintf(stderr, "Reserving heap at 0x" LISP ", size 0x" LISP "\n", start, totalsize);
     212  fprintf(dbgout, "Reserving heap at 0x" LISP ", size 0x" LISP "\n", start, totalsize);
    213213#endif
    214214  return start;
     
    220220  LogicalAddress rc;
    221221#if DEBUG_MEMORY
    222   fprintf(stderr, "Committing memory at 0x" LISP ", size 0x" LISP "\n", start, len);
     222  fprintf(dbgout, "Committing memory at 0x" LISP ", size 0x" LISP "\n", start, len);
    223223#endif
    224224#ifdef WINDOWS
     
    258258UnCommitMemory (LogicalAddress start, natural len) {
    259259#if DEBUG_MEMORY
    260   fprintf(stderr, "Uncommitting memory at 0x" LISP ", size 0x" LISP "\n", start, len);
     260  fprintf(dbgout, "Uncommitting memory at 0x" LISP ", size 0x" LISP "\n", start, len);
    261261#endif
    262262#ifdef WINDOWS
     
    274274      int err = errno;
    275275      Fatal("mmap error", "");
    276       fprintf(stderr, "errno = %d", err);
     276      fprintf(dbgout, "errno = %d", err);
    277277    }
    278278  }
     
    285285{
    286286#if DEBUG_MEMORY
    287   fprintf(stderr, "Mapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
     287  fprintf(dbgout, "Mapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
    288288#endif
    289289#ifdef WINDOWS
     
    298298{
    299299#if DEBUG_MEMORY
    300   fprintf(stderr, "Mapping stack of size 0x" LISP "\n", nbytes);
     300  fprintf(dbgout, "Mapping stack of size 0x" LISP "\n", nbytes);
    301301#endif
    302302#ifdef WINDOWS
     
    311311{
    312312#if DEBUG_MEMORY
    313   fprintf(stderr, "Unmapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
     313  fprintf(dbgout, "Unmapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
    314314#endif
    315315#ifdef WINDOWS
     
    325325{
    326326#if DEBUG_MEMORY
    327   fprintf(stderr, "Protecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
     327  fprintf(dbgout, "Protecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
    328328#endif
    329329#ifdef WINDOWS
     
    351351{
    352352#if DEBUG_MEMORY
    353   fprintf(stderr, "Unprotecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
     353  fprintf(dbgout, "Unprotecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes);
    354354#endif
    355355#ifdef WINDOWS
     
    404404    count = read(fd, addr + total, nbytes - total);
    405405    total += count;
    406     // fprintf(stderr, "read " DECIMAL " bytes, for a total of " DECIMAL " out of " DECIMAL " so far\n", count, total, nbytes);
     406    // fprintf(dbgout, "read " DECIMAL " bytes, for a total of " DECIMAL " out of " DECIMAL " so far\n", count, total, nbytes);
    407407    if (!(count > 0))
    408408      return false;
  • branches/working-0711/ccl/lisp-kernel/memprotect.h

    r10944 r12198  
    2626#include <signal.h>
    2727#ifndef WINDOWS
     28#ifdef DARWIN
     29#include <sys/ucontext.h>
     30#else
    2831#include <ucontext.h>
     32#endif
    2933#endif
    3034
  • branches/working-0711/ccl/lisp-kernel/plbt.c

    r10944 r12198  
    105105      unsigned long strtable = (unsigned long)(((struct symtab_command *)lc)->stroff + table_off);
    106106      for (i = 0; i < numsyms; i++) {
    107         /* fprintf(stderr,"%s : 0x%08x, 0x%x\n",(char *)(strtable + symtable->n_un.n_strx) ,symtable->n_value, symtable->n_type); */
     107        /* fprintf(dbgout,"%s : 0x%08x, 0x%x\n",(char *)(strtable + symtable->n_un.n_strx) ,symtable->n_value, symtable->n_type); */
    108108        /* Ignore the following kinds of Symbols */
    109109        if ((!symtable->n_value)        /* Undefined */
     
    254254    }
    255255    if (next < start) {
    256       fprintf(stderr, "Bad frame! (%x < %x)\n", next, start);
     256      fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start);
    257257      break;
    258258    }
     
    304304      Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP);
    305305    } else {
    306       fprintf(stderr, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
     306      fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
    307307      walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high));
    308308      walk_other_areas();
  • branches/working-0711/ccl/lisp-kernel/plprint.c

    r6 r12198  
    2222{
    2323  if (lisp_nil == (LispObj) NULL) {
    24     fprintf(stderr,"can't find lisp NIL; lisp process not active process ?\n");
     24    fprintf(dbgout,"can't find lisp NIL; lisp process not active process ?\n");
    2525  } else {
    2626    Dprintf("\n%s", print_lisp_object(obj));
  • branches/working-0711/ccl/lisp-kernel/plsym.c

    r10944 r12198  
    121121    describe_symbol(address);
    122122  } else {
    123     fprintf(stderr, "Not a symbol.\n");
     123    fprintf(dbgout, "Not a symbol.\n");
    124124  }
    125125  return;
  • branches/working-0711/ccl/lisp-kernel/pmcl-kernel.c

    r11498 r12198  
    139139                (LPTSTR)&buffer,
    140140                0, NULL);
    141   fprintf(stderr, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer);
     141  fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer);
    142142  LocalFree(buffer);
    143143}
     
    153153extern LispObj nvalret;
    154154extern LispObj popj;
    155 #ifdef X86
    156 extern LispObj bad_funcall;
    157 #endif
    158155
    159156LispObj text_start = 0;
     
    205202    if (setrlimit(RLIMIT_STACK, &limits)) {
    206203      int e = errno;
    207       fprintf(stderr, "errno = %d\n", e);
     204      fprintf(dbgout, "errno = %d\n", e);
    208205      Fatal(": Stack resource limit too small", "");
    209206    }
     
    401398#endif
    402399#ifdef LINUX
     400#ifdef X86
     401#define MAXIMUM_MAPPABLE_MEMORY (9U<<28)
     402#else
    403403#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
     404#endif
    404405#endif
    405406#ifdef WINDOWS
     
    440441#define G0_AREA_THRESHOLD (1<<20)
    441442#endif
     443
     444#define MIN_DYNAMIC_SIZE (DEFAULT_LISP_HEAP_GC_THRESHOLD *2)
    442445
    443446#if (WORD_SIZE == 32)
     
    568571    want = (BytePtr)IMAGE_BASE_ADDRESS;
    569572  area *reserved;
     573  Boolean fatal = false;
    570574
    571575  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
     576   
     577  if (totalsize < (PURESPACE_RESERVE + MIN_DYNAMIC_SIZE)) {
     578    totalsize = PURESPACE_RESERVE + MIN_DYNAMIC_SIZE;
     579    fatal = true;
     580  }
    572581
    573582  start = ReserveMemoryForHeap(want, totalsize);
     583
     584  if (start == NULL) {
     585    if (fatal) {
     586      perror("minimal initial mmap");
     587      exit(1);
     588    }
     589    return NULL;
     590  }
    574591
    575592  h = (Ptr) start;
     
    629646    ndnodes = area_dnode(lisp_global(HEAP_END),lisp_global(HEAP_START)),
    630647    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
    631     reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1));
     648    reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1)),
     649    n;
    632650  BytePtr
    633     new_reloctab_limit = ((BytePtr)global_reloctab)+reloctab_size,
    634     new_markbits_limit = ((BytePtr)global_mark_ref_bits)+markbits_size;
     651    new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size),
     652    new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)global_mark_ref_bits)+markbits_size,log2_page_size);
    635653
    636654  if (new_reloctab_limit > reloctab_limit) {
    637     CommitMemory(global_reloctab, reloctab_size);
    638     UnProtectMemory(global_reloctab, reloctab_size);
     655    n = new_reloctab_limit - reloctab_limit;
     656    CommitMemory(reloctab_limit, n);
     657    UnProtectMemory(reloctab_limit, n);
    639658    reloctab_limit = new_reloctab_limit;
    640659  }
    641660 
    642661  if (new_markbits_limit > markbits_limit) {
    643     CommitMemory(global_mark_ref_bits, markbits_size);
    644     UnProtectMemory(global_mark_ref_bits, markbits_size);
     662    n = new_markbits_limit-markbits_limit;
     663    CommitMemory(markbits_limit, n);
     664    UnProtectMemory(markbits_limit, n);
    645665    markbits_limit = new_markbits_limit;
    646666  }
     
    657677  start = allocate_from_reserved_area(totalsize);
    658678  if (start == NULL) {
    659     return NULL;
     679    fprintf(dbgout, "reserved area too small to load heap image\n");
     680    exit(1);
    660681  }
    661682  end = start + totalsize;
     
    671692  lisp_global(HEAP_START) = ptr_to_lispobj(a->low);
    672693  lisp_global(HEAP_END) = ptr_to_lispobj(a->high);
     694  markbits_limit = (BytePtr)global_mark_ref_bits;
     695  reloctab_limit = (BytePtr)global_reloctab;
    673696  ensure_gc_structures_writable();
    674697  return a;
     
    728751
    729752
    730 
     753#ifndef WINDOWS
    731754void
    732755user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context)
     
    746769}
    747770
     771#endif
    748772
    749773void
     
    794818    fatal_spare_ptr = NULL;
    795819  }
    796   fprintf(stderr, "Fatal error: %s\n%s\n", param0, param1);
     820  fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1);
    797821  _exit(-1);
    798822}
     
    818842#ifdef WINDOWS
    819843/* Chop the trailing ".exe" from the kernel image name */
    820 char *
    821 chop_exe_suffix(char *path)
    822 {
    823   int len = strlen(path);
    824   char *copy = malloc(len+1), *tail;
    825 
    826   strcpy(copy,path);
    827   tail = strrchr(copy, '.');
     844wchar_t *
     845chop_exe_suffix(wchar_t *path)
     846{
     847  int len = wcslen(path);
     848  wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail;
     849
     850  wcscpy(copy,path);
     851  tail = wcsrchr(copy, '.');
    828852  if (tail) {
    829853    *tail = 0;
     
    833857#endif
    834858
     859#ifdef WINDOWS
     860wchar_t *
     861path_by_appending_image(wchar_t *path)
     862{
     863  int len = wcslen(path) + wcslen(L".image") + 1;
     864  wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t));
     865
     866  if (copy) {
     867    wcscpy(copy, path);
     868    wcscat(copy, L".image");
     869  }
     870  return copy;
     871}
     872#else
    835873char *
    836874path_by_appending_image(char *path)
     
    845883  return copy;
    846884}
     885#endif
    847886
    848887char *
     
    873912   Tack ".image" onto the end of the kernel's name.  Much better ...
    874913*/
     914#ifdef WINDOWS
     915wchar_t *
     916default_image_name(wchar_t *orig)
     917{
     918  wchar_t *path = chop_exe_suffix(orig);
     919  wchar_t *image_name = path_by_appending_image(path);
     920  return image_name;
     921}
     922#else
    875923char *
    876924default_image_name(char *orig)
     
    892940  return image_name;
    893941}
     942#endif
    894943
    895944
    896945
    897946char *program_name = NULL;
     947#ifdef WINDOWS
     948wchar_t *real_executable_name = NULL;
     949#else
    898950char *real_executable_name = NULL;
     951#endif
     952
     953#ifndef WINDOWS
     954
     955char *
     956ensure_real_path(char *path)
     957{
     958  char buf[PATH_MAX*2], *p, *q;
     959  int n;
     960
     961  p = realpath(path, buf);
     962 
     963  if (p == NULL) {
     964    return path;
     965  }
     966  n = strlen(p);
     967  q = malloc(n+1);
     968  strcpy(q,p);
     969  return q;
     970}
    899971
    900972char *
     
    909981    memmove(p, exepath, len);
    910982    p[len]=0;
    911     return p;
     983    return ensure_real_path(p);
    912984  }
    913   return argv0;
     985  return ensure_real_path(argv0);
    914986#endif
    915987#ifdef LINUX
     
    926998#endif
    927999#ifdef FREEBSD
    928   return argv0;
     1000  return ensure_real_path(argv0);
    9291001#endif
    9301002#ifdef SOLARIS
     
    9401012    return p;
    9411013  }
    942   return argv0;
    943 #endif
    944 #ifdef WINDOWS
    945   char path[PATH_MAX], *p;
    946   int len = GetModuleFileName(NULL, path, PATH_MAX);
    947   if (len > 0) {
    948     p = malloc(len + 1);
    949     memmove(p, path, len);
    950     p[len] = 0;
    951     return p;
    952   }
    953   return argv0;
    954 #endif
    955 }
     1014  return ensure_real_path(argv0);
     1015#endif
     1016  return ensure_real_path(argv0);
     1017}
     1018#endif
     1019
     1020#ifdef WINDOWS
     1021wchar_t *
     1022ensure_real_path(wchar_t *path)
     1023{
     1024  int bufsize = 256, n;
     1025
     1026  do {
     1027    wchar_t buf[bufsize];
     1028
     1029    n = GetFullPathNameW(path,bufsize,buf,NULL);
     1030    if (n == 0) {
     1031      return path;
     1032    }
     1033
     1034    if (n < bufsize) {
     1035      int i;
     1036      wchar_t *q = calloc(n+1,sizeof(wchar_t));
     1037
     1038      for (i = 0; i < n; i++) {
     1039        q[i] = buf[i];
     1040      }
     1041      return q;
     1042    }
     1043    bufsize = n+1;
     1044  } while (1);
     1045}
     1046#endif
    9561047
    9571048void
     
    9591050{
    9601051  if (herald && *herald) {
    961     fprintf(stderr, "%s\n", herald);
    962   }
    963   fprintf(stderr, "usage: %s <options>\n", program_name);
    964   fprintf(stderr, "\t or %s <image-name>\n", program_name);
    965   fprintf(stderr, "\t where <options> are one or more of:\n");
     1052    fprintf(dbgout, "%s\n", herald);
     1053  }
     1054  fprintf(dbgout, "usage: %s <options>\n", program_name);
     1055  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
     1056  fprintf(dbgout, "\t where <options> are one or more of:\n");
    9661057  if (other_args && *other_args) {
    967     fputs(other_args, stderr);
    968   }
    969   fprintf(stderr, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
     1058    fputs(other_args, dbgout);
     1059  }
     1060  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
    9701061          (u64_t) reserved_area_size);
    971   fprintf(stderr, "\t\t bytes for heap expansion\n");
    972   fprintf(stderr, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
    973   fprintf(stderr, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
    974   fprintf(stderr, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
    975   fprintf(stderr, "\t--no-sigtrap : obscure option for running under GDB\n");
    976   fprintf(stderr, "\t-I, --image-name <image-name>\n");
    977   fprintf(stderr, "\t and <image-name> defaults to %s\n",
     1062  fprintf(dbgout, "\t\t bytes for heap expansion\n");
     1063  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
     1064  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
     1065  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
     1066  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
     1067  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
     1068#ifndef WINDOWS
     1069  fprintf(dbgout, "\t and <image-name> defaults to %s\n",
    9781070          default_image_name(program_name));
    979   fprintf(stderr, "\n");
     1071#endif
     1072  fprintf(dbgout, "\n");
    9801073  _exit(exit_status);
    9811074}
    9821075
    9831076int no_sigtrap = 0;
     1077#ifdef WINDOWS
     1078wchar_t *image_name = NULL;
     1079#else
    9841080char *image_name = NULL;
     1081#endif
    9851082int batch_flag = 0;
    9861083
     
    10131110   
    10141111  default:
    1015     fprintf(stderr, "couldn't parse %s argument %s", argname, arg);
     1112    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
    10161113    val = default_val;
    10171114    break;
     
    10301127
    10311128void
    1032 process_options(int argc, char *argv[])
     1129process_options(int argc, char *argv[], wchar_t *shadow[])
    10331130{
    10341131  int i, j, k, num_elide, flag, arg_error;
    10351132  char *arg, *val;
     1133  wchar_t *warg, *wval;
    10361134#ifdef DARWIN
    10371135  extern int NXArgc;
     
    10401138  for (i = 1; i < argc;) {
    10411139    arg = argv[i];
     1140    if (shadow) {
     1141      warg = shadow[i];
     1142    }
    10421143    arg_error = 0;
    10431144    if (*arg != '-') {
     
    10491150          (strcmp (arg, "--image-name") == 0)) {
    10501151        if (flag && arg[2]) {
    1051           val = arg+2;
     1152          val = arg+2;         
     1153          if (shadow) {
     1154            wval = warg+2;
     1155          }
    10521156          num_elide = 1;
    10531157        } else {
    10541158          if ((i+1) < argc) {
    10551159            val = argv[i+1];
     1160            if (shadow) {
     1161              wval = shadow[i+1];
     1162            }
    10561163            num_elide = 2;
    10571164          } else {
     
    10601167        }
    10611168        if (val) {
     1169#ifdef WINDOWS
     1170          image_name = wval;
     1171#else
    10621172          image_name = val;
     1173#endif
    10631174        }
    10641175      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
     
    11641275        for (j = i+num_elide, k=i; j < argc; j++, k++) {
    11651276          argv[k] = argv[j];
     1277          if (shadow) {
     1278            shadow[k] = shadow[j];
     1279          }
    11661280        }
    11671281        argc -= num_elide;
     
    12101324#endif
    12111325
    1212 #ifdef DARWIN
    1213 #ifdef PPC64
     1326#ifdef PPC
     1327#if defined(PPC64) || !defined(DARWIN)
    12141328/* ld64 on Darwin doesn't offer anything close to reliable control
    12151329   over the layout of a program in memory.  About all that we can
     
    13421456
    13431457  if (got < want) {
    1344     fprintf(stderr, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
     1458    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
    13451459    exit(1);
    13461460  }
     
    13791493{
    13801494  natural eax, ebx, ecx, edx;
    1381  
     1495
    13821496  eax = cpuid(0, &ebx, &ecx, &edx);
    13831497
     
    13881502      return true;
    13891503    }
     1504    /* It's very unlikely that SSE2 would be present and other things
     1505       that we want wouldn't.  If they don't have MMX or CMOV either,
     1506       might as well tell them. */
     1507    if ((edx & X86_FEATURE_SSE2) == 0) {
     1508      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
     1509    }
     1510    if ((edx & X86_FEATURE_MMX) == 0) {
     1511      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
     1512    }
     1513    if ((edx & X86_FEATURE_CMOV) == 0) {
     1514      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
     1515    }
     1516   
    13901517  }
    13911518  return false;
     
    14251552  arch_prctl(ARCH_GET_FS, &fs_addr);
    14261553  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
    1427     fprintf(stderr, "The installed C library - version %s - seems to be using the %%gs register for thread storage.\n\"%s\" cannot run, since it expects to be\nable to use that register for its own purposes.\n", gnu_get_libc_version(),progname);
     1554    fprintf(dbgout, "The installed C library - version %s - seems to be using the %%gs register for thread storage.\n\"%s\" cannot run, since it expects to be\nable to use that register for its own purposes.\n", gnu_get_libc_version(),progname);
    14281555    _exit(1);
    14291556  }
     
    14631590}
    14641591
     1592#ifdef WINDOWS
     1593char *
     1594utf_16_to_utf_8(wchar_t *utf_16)
     1595{
     1596  int utf8len = WideCharToMultiByte(CP_UTF8,
     1597                                    0,
     1598                                    utf_16,
     1599                                    -1,
     1600                                    NULL,
     1601                                    0,
     1602                                    NULL,
     1603                                    NULL);
     1604
     1605  char *utf_8 = malloc(utf8len);
     1606
     1607  WideCharToMultiByte(CP_UTF8,
     1608                      0,
     1609                      utf_16,
     1610                      -1,
     1611                      utf_8,
     1612                      utf8len,
     1613                      NULL,
     1614                      NULL);
     1615
     1616  return utf_8;
     1617}
     1618
     1619char **
     1620wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
     1621{
     1622  char** argv = calloc(argc+1,sizeof(char *));
     1623  int i;
     1624
     1625  for (i = 0; i < argc; i++) {
     1626    argv[i] = utf_16_to_utf_8(wide_argv[i]);
     1627  }
     1628  return argv;
     1629}
     1630#endif
     1631
     1632
     1633 
     1634
    14651635
    14661636int
     
    14721642{
    14731643  extern int page_size;
     1644  natural default_g0_threshold = G0_AREA_THRESHOLD,
     1645    default_g1_threshold = G1_AREA_THRESHOLD,
     1646    default_g2_threshold = G2_AREA_THRESHOLD,
     1647    lisp_heap_threshold_from_image = 0;
     1648  Boolean egc_enabled =
     1649#ifdef DISABLE_EGC
     1650    false
     1651#else
     1652    true
     1653#endif
     1654    ;
     1655  Boolean lisp_heap_threshold_set_from_command_line = false;
     1656  wchar_t **utf_16_argv = NULL;
    14741657
    14751658#ifdef PPC
    14761659  extern int altivec_present;
    14771660#endif
     1661#ifdef WINDOWS
     1662  extern LispObj load_image(wchar_t *);
     1663#else
    14781664  extern LispObj load_image(char *);
     1665#endif
    14791666  area *a;
    14801667  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
    14811668  TCR *tcr;
    14821669
    1483 
    1484 #ifdef WINDOWS
    1485   extern void init_winsock(void);
    1486   extern void init_windows_io(void);
    1487 
    1488   _fmode = O_BINARY;
    1489   _setmode(1, O_BINARY);
    1490   _setmode(2, O_BINARY);
    1491   setvbuf(stderr, NULL, _IONBF, 0);
    1492   init_winsock();
    1493   init_windows_io();
     1670  dbgout = stderr;
     1671
     1672#ifdef WINDOWS
     1673  {
     1674    int wide_argc;
     1675    extern void init_winsock(void);
     1676    extern void init_windows_io(void);
     1677
     1678    _fmode = O_BINARY;
     1679    _setmode(1, O_BINARY);
     1680    _setmode(2, O_BINARY);
     1681    setvbuf(dbgout, NULL, _IONBF, 0);
     1682    init_winsock();
     1683    init_windows_io();
     1684    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
     1685  }
    14941686#endif
    14951687
    14961688  check_os_version(argv[0]);
     1689#ifdef WINDOWS
     1690  real_executable_name = utf_16_argv[0];
     1691#else
    14971692  real_executable_name = determine_executable_name(argv[0]);
     1693#endif
    14981694  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
    14991695
     
    15041700#endif
    15051701#endif
    1506 #if (defined(DARWIN) && defined(PPC64)) || defined(X8664) || (defined(X8632) && !defined(DARWIN))
     1702#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
    15071703  remap_spjump();
    15081704#endif
     
    15621758#ifdef X86
    15631759  if (!check_x86_cpu()) {
    1564     fprintf(stderr, "CPU doesn't support required features\n");
     1760    fprintf(dbgout, "CPU doesn't support required features\n");
    15651761    exit(1);
    15661762  }
     
    15831779  program_name = argv[0];
    15841780  if ((argc == 2) && (*argv[1] != '-')) {
     1781#ifdef WINDOWS
     1782    image_name = utf_16_argv[1];
     1783#else
    15851784    image_name = argv[1];
     1785#endif
    15861786    argv[1] = NULL;
     1787#ifdef WINDOWS
     1788    utf_16_argv[1] = NULL;
     1789#endif
    15871790  } else {
    1588     process_options(argc,argv);
    1589   }
     1791    process_options(argc,argv,utf_16_argv);
     1792  }
     1793  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
     1794    lisp_heap_threshold_set_from_command_line = true;
     1795  }
     1796
    15901797  initial_stack_size = ensure_stack_limit(initial_stack_size);
    15911798  if (image_name == NULL) {
     
    15971804  }
    15981805
    1599 
    1600   if (!create_reserved_area(reserved_area_size)) {
    1601     exit(-1);
    1602   }
     1806  while (1) {
     1807    if (create_reserved_area(reserved_area_size)) {
     1808      break;
     1809    }
     1810    reserved_area_size = reserved_area_size *.9;
     1811  }
     1812
    16031813  gc_init();
    16041814
    16051815  set_nil(load_image(image_name));
     1816  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
     1817  if (lisp_heap_threshold_from_image) {
     1818    if ((!lisp_heap_threshold_set_from_command_line) &&
     1819        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
     1820      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
     1821      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
     1822    }
     1823    /* If lisp_heap_threshold_from_image was set, other image params are
     1824       valid. */
     1825    default_g0_threshold = lisp_global(G0_THRESHOLD);
     1826    default_g1_threshold = lisp_global(G1_THRESHOLD);
     1827    default_g2_threshold = lisp_global(G2_THRESHOLD);
     1828    egc_enabled = lisp_global(EGC_ENABLED);
     1829  }
     1830
    16061831  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
    16071832
     
    16151840  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
    16161841  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
    1617 #ifdef X86
    1618   lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall);
    1619 #endif
    16201842  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
    16211843  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
     
    16261848 
    16271849
    1628   lisp_global(IMAGE_NAME) = ptr_to_lispobj(image_name);
     1850#ifdef WINDOWS
     1851  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
     1852  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
     1853  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
     1854#else
     1855  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
     1856  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
    16291857  lisp_global(ARGV) = ptr_to_lispobj(argv);
     1858#endif
    16301859  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
    16311860
     
    16671896    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
    16681897    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
    1669     g2_area->threshold = G2_AREA_THRESHOLD;
    1670     g1_area->threshold = G1_AREA_THRESHOLD;
    1671     a->threshold = G0_AREA_THRESHOLD;
     1898    g2_area->threshold = default_g2_threshold;
     1899    g1_area->threshold = default_g1_threshold;
     1900    a->threshold = default_g0_threshold;
    16721901  }
    16731902
     
    16971926  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
    16981927#endif
    1699 #ifndef DISABLE_EGC
    1700   egc_control(true, NULL);
    1701 #endif
     1928  if (egc_enabled) {
     1929    egc_control(true, NULL);
     1930  }
    17021931  atexit(lazarus);
    17031932  start_lisp(TCR_TO_TSD(tcr), 0);
     
    19062135
    19072136Boolean
    1908 check_for_embedded_image (char *path)
    1909 {
     2137check_for_embedded_image (
     2138#ifdef WINDOWS
     2139                          wchar_t *path
     2140#else
     2141                          char *path
     2142#endif
     2143                          )
     2144{
     2145#ifdef WINDOWS
     2146  int fd = wopen(path, O_RDONLY);
     2147#else 
    19102148  int fd = open(path, O_RDONLY);
     2149#endif
     2150
    19112151  Boolean image_is_embedded = false;
    19122152
     
    19232163
    19242164LispObj
    1925 load_image(char *path)
    1926 {
     2165load_image(
     2166#ifdef WINDOWS
     2167           wchar_t * path
     2168#else
     2169           char *path
     2170#endif
     2171)
     2172{
     2173#ifdef WINDOWS
     2174  int fd = wopen(path, O_RDONLY, 0666), err;
     2175#else
    19272176  int fd = open(path, O_RDONLY, 0666), err;
     2177#endif
    19282178  LispObj image_nil = 0;
    19292179
    1930   errno = 0;
    19312180  if (fd > 0) {
    19322181    openmcl_image_file_header ih;
     2182
     2183    errno = 0;
    19332184    image_nil = load_openmcl_image(fd, &ih);
    19342185    /* We -were- using a duplicate fd to map the file; that
     
    19522203  if (image_nil == 0) {
    19532204    if (err == 0) {
    1954       fprintf(stderr, "Couldn't load lisp heap image from %s\n", path);
     2205      fprintf(dbgout, "Couldn't load lisp heap image from %s\n", path);
    19552206    } else {
    1956       fprintf(stderr, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(err));
     2207      fprintf(dbgout, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(err));
    19572208    }
    19582209    exit(-1);
  • branches/working-0711/ccl/lisp-kernel/ppc-constants.s

    r4315 r12198  
    208208         _node(all_areas)               /* doubly-linked list of all memory areas */
    209209         _node(BAD_cs_overflow_limit)   /* limit for control-stack overflow check */
    210          _node(BAD_current_ts)          /* current temp-stack area */
     210         _node(kernel_name)             /* real executable name */
    211211         _node(BAD_current_vs)          /* current value-stack area */
    212212         _node(statically_linked)       /* non-zero if -static */
  • branches/working-0711/ccl/lisp-kernel/ppc-constants32.h

    r11089 r12198  
    380380#define lfbits_noname_mask fixnum_bitmask(29)
    381381
    382 /*
    383   known values of an "extended" (gcable) macptr's flags word:
    384 */
    385 
    386 typedef enum {
    387   xmacptr_flag_none = 0,        /* Maybe already disposed by Lisp */
    388   xmacptr_flag_recursive_lock,  /* recursive-lock */
    389   xmacptr_flag_ptr,             /* malloc/free */
    390   xmacptr_flag_rwlock,          /* read/write lock */
    391   xmacptr_flag_semaphore        /* semaphore */
    392 } xmacptr_flag;
    393382
    394383/* Creole */
  • branches/working-0711/ccl/lisp-kernel/ppc-constants64.h

    r11089 r12198  
    360360#define lfbits_noname_mask fixnum_bitmask(29)
    361361
    362 /*
    363   known values of an "extended" (gcable) macptr's flags word:
    364 */
    365 
    366 typedef enum {
    367   xmacptr_flag_none = 0,        /* Maybe already disposed by Lisp */
    368   xmacptr_flag_recursive_lock,  /* recursive-lock */
    369   xmacptr_flag_ptr,             /* malloc/free */
    370   xmacptr_flag_rwlock,          /* read/write lock */
    371   xmacptr_flag_semaphore        /* semaphore */
    372 } xmacptr_flag;
    373362
    374363/* Creole */
  • branches/working-0711/ccl/lisp-kernel/ppc-exceptions.c

    r11660 r12198  
    252252    xpGPR(xp, allocptr) += disp_from_allocptr;
    253253#ifdef DEBUG
    254     fprintf(stderr, "New heap segment for #x%x, no GC: #x%x/#x%x, vsp = #x%x\n",
     254    fprintf(dbgout, "New heap segment for #x%x, no GC: #x%x/#x%x, vsp = #x%x\n",
    255255            tcr,xpGPR(xp,allocbase),tcr->last_allocptr, xpGPR(xp,vsp));
    256256#endif
     
    271271    xpGPR(xp, allocptr) += disp_from_allocptr;
    272272#ifdef DEBUG
    273     fprintf(stderr, "New heap segment for #x%x after GC: #x%x/#x%x\n",
     273    fprintf(dbgout, "New heap segment for #x%x after GC: #x%x/#x%x\n",
    274274            tcr,xpGPR(xp,allocbase),tcr->last_allocptr);
    275275#endif
     
    294294  }
    295295  tcr->last_allocptr = 0;
     296}
     297
     298void
     299lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed)
     300{
     301  /* Couldn't allocate the object.  If it's smaller than some arbitrary
     302     size (say 128K bytes), signal a "chronically out-of-memory" condition;
     303     else signal a "allocation request failed" condition.
     304  */
     305  xpGPR(xp,allocptr) = xpGPR(xp,allocbase) = VOID_ALLOCPTR;
     306  handle_error(xp, bytes_needed < (128<<10) ? XNOMEM : error_alloc_failed, 0, 0,  xpPC(xp));
     307}
     308
     309/*
     310  Allocate a large list, where "large" means "large enough to
     311  possibly trigger the EGC several times if this was done
     312  by individually allocating each CONS."  The number of
     313  ocnses in question is in arg_z; on successful return,
     314  the list will be in arg_z
     315*/
     316
     317Boolean
     318allocate_list(ExceptionInformation *xp, TCR *tcr)
     319{
     320  natural
     321    nconses = (unbox_fixnum(xpGPR(xp,arg_z))),
     322    bytes_needed = (nconses << dnode_shift);
     323  LispObj
     324    prev = lisp_nil,
     325    current,
     326    initial = xpGPR(xp,arg_y);
     327
     328  if (nconses == 0) {
     329    /* Silly case */
     330    xpGPR(xp,arg_z) = lisp_nil;
     331    xpGPR(xp,allocptr) = lisp_nil;
     332    return true;
     333  }
     334  update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr);
     335  if (allocate_object(xp,bytes_needed,(-bytes_needed)+fulltag_cons,tcr)) {
     336    for (current = xpGPR(xp,allocptr);
     337         nconses;
     338         prev = current, current+= dnode_size, nconses--) {
     339      deref(current,0) = prev;
     340      deref(current,1) = initial;
     341    }
     342    xpGPR(xp,arg_z) = prev;
     343    xpGPR(xp,arg_y) = xpGPR(xp,allocptr);
     344    xpGPR(xp,allocptr)-=fulltag_cons;
     345  } else {
     346    lisp_allocation_failure(xp,tcr,bytes_needed);
     347  }
     348  return true;
    296349}
    297350
     
    347400    if (allocate_object(xp, bytes_needed, disp, tcr)) {
    348401#if 0
    349       fprintf(stderr, "alloc_trap in 0x%lx, new allocptr = 0x%lx\n",
     402      fprintf(dbgout, "alloc_trap in 0x%lx, new allocptr = 0x%lx\n",
    350403              tcr, xpGPR(xp, allocptr));
    351404#endif
     
    353406      return 0;
    354407    }
    355     /* Couldn't allocate the object.  If it's smaller than some arbitrary
    356        size (say 128K bytes), signal a "chronically out-of-memory" condition;
    357        else signal a "allocation request failed" condition.
    358     */
    359     xpGPR(xp,allocptr) = xpGPR(xp,allocbase) = VOID_ALLOCPTR;
    360     handle_error(xp, bytes_needed < (128<<10) ? XNOMEM : error_alloc_failed, 0, 0,  xpPC(xp));
     408    lisp_allocation_failure(xp,tcr,bytes_needed);
    361409    return -1;
    362410  }
     
    365413
    366414natural gc_deferred = 0, full_gc_deferred = 0;
     415
     416signed_natural
     417flash_freeze(TCR *tcr, signed_natural param)
     418{
     419  return 0;
     420}
    367421
    368422OSStatus
     
    413467    }
    414468    xpGPR(xp, imm0) = lisp_heap_gc_threshold;
     469    break;
     470
     471  case GC_TRAP_FUNCTION_FLASH_FREEZE:
     472    untenure_from_area(tenured_area);
     473    gc_like_from_xp(xp,flash_freeze,0);
     474    a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
     475    tenured_area->static_dnodes = area_dnode(a->active, a->low);
     476    if (egc_was_enabled) {
     477      tenure_to_area(tenured_area);
     478    }
     479    xpGPR(xp, imm0) = tenured_area->static_dnodes << dnode_shift;
    415480    break;
    416481
     
    450515      if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) {
    451516        OSErr err;
    452         extern OSErr save_application(unsigned);
     517        extern OSErr save_application(unsigned, Boolean);
    453518        TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext));
    454519        area *vsarea = tcr->vs_area;
    455520       
    456521        nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1);
    457         err = save_application(arg);
     522        err = save_application(arg, egc_was_enabled);
    458523        if (err == noErr) {
    459524          _exit(0);
     
    658723    update_area_active((area **)&tcr->ts_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, tsp)));
    659724#ifdef DEBUG
    660     fprintf(stderr, "TCR 0x%x in lisp code, vsp = 0x%lx, tsp = 0x%lx\n",
     725    fprintf(dbgout, "TCR 0x%x in lisp code, vsp = 0x%lx, tsp = 0x%lx\n",
    661726            tcr, xpGPR(xp, vsp), xpGPR(xp, tsp));
    662     fprintf(stderr, "TCR 0x%x, allocbase/allocptr were 0x%x/0x%x at #x%x\n",
     727    fprintf(dbgout, "TCR 0x%x, allocbase/allocptr were 0x%x/0x%x at #x%x\n",
    663728            tcr,
    664729            xpGPR(xp, allocbase),
    665730            xpGPR(xp, allocptr),
    666731            xpPC(xp));
    667     fprintf(stderr, "TCR 0x%x, exception context = 0x%x\n",
     732    fprintf(dbgout, "TCR 0x%x, exception context = 0x%x\n",
    668733            tcr,
    669734            tcr->pending_exception_context);
     
    673738    cur_allocptr = (void *) (tcr->save_allocptr);
    674739#ifdef DEBUG
    675     fprintf(stderr, "TCR 0x%x in foreign code, vsp = 0x%lx, tsp = 0x%lx\n",
     740    fprintf(dbgout, "TCR 0x%x in foreign code, vsp = 0x%lx, tsp = 0x%lx\n",
    676741            tcr, tcr->save_vsp, tcr->save_tsp);
    677     fprintf(stderr, "TCR 0x%x, save_allocbase/save_allocptr were 0x%x/0x%x at #x%x\n",
     742    fprintf(dbgout, "TCR 0x%x, save_allocbase/save_allocptr were 0x%x/0x%x at #x%x\n",
    678743            tcr,
    679744            tcr->save_allocbase,
     
    703768   function returned */
    704769
    705 int
     770signed_natural
    706771gc_like_from_xp(ExceptionInformation *xp,
    707                 int(*fun)(TCR *, signed_natural),
     772                signed_natural(*fun)(TCR *, signed_natural),
    708773                signed_natural param)
    709774{
     
    765830
    766831
     832
    767833/* Returns #bytes freed by invoking GC */
    768834
    769 int
     835signed_natural
    770836gc_from_tcr(TCR *tcr, signed_natural param)
    771837{
     
    775841
    776842#ifdef DEBUG
    777   fprintf(stderr, "Start GC  in 0x%lx\n", tcr);
     843  fprintf(dbgout, "Start GC  in 0x%lx\n", tcr);
    778844#endif
    779845  a = active_dynamic_area;
     
    784850  newend = a->high;
    785851#if 0
    786   fprintf(stderr, "End GC  in 0x%lx\n", tcr);
     852  fprintf(dbgout, "End GC  in 0x%lx\n", tcr);
    787853#endif
    788854  return ((oldfree-newfree)+(newend-oldend));
    789855}
    790856
    791 int
     857signed_natural
    792858gc_from_xp(ExceptionInformation *xp, signed_natural param)
    793859{
    794   int status = gc_like_from_xp(xp, gc_from_tcr, param);
     860  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
    795861
    796862  freeGCptrs();
     
    798864}
    799865
    800 int
     866signed_natural
    801867purify_from_xp(ExceptionInformation *xp, signed_natural param)
    802868{
     
    804870}
    805871
    806 int
     872signed_natural
    807873impurify_from_xp(ExceptionInformation *xp, signed_natural param)
    808874{
     
    13731439        xpGPR(xp,imm0) = (LispObj)kill_tcr(target);
    13741440        break;
     1441      case error_allocate_list:
     1442        allocate_list(xp,get_tcr(true));
     1443        break;
    13751444      default:
    13761445        status = handle_error(xp, errnum, rb, 0,  where);
     
    14761545  callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
    14771546#ifdef DEBUG
    1478   fprintf(stderr, "0x%x releasing exception lock for callback\n", tcr);
     1547  fprintf(dbgout, "0x%x releasing exception lock for callback\n", tcr);
    14791548#endif
    14801549  UNLOCK(lisp_global(EXCEPTION_LOCK), tcr);
     
    14821551  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
    14831552#ifdef DEBUG
    1484   fprintf(stderr, "0x%x acquired exception lock after callback\n", tcr);
     1553  fprintf(dbgout, "0x%x acquired exception lock after callback\n", tcr);
    14851554#endif
    14861555
     
    16201689      }
    16211690#if 0
    1622       fprintf(stderr, "About to do trap callback in 0x%x\n",tcr);
     1691      fprintf(dbgout, "About to do trap callback in 0x%x\n",tcr);
    16231692#endif
    16241693      callback_for_trap(cmain, xp,  where, (natural) the_trap,  0, 0);
     
    16521721void non_fatal_error( char *msg )
    16531722{
    1654   fprintf( stderr, "Non-fatal error: %s.\n", msg );
    1655   fflush( stderr );
     1723  fprintf( dbgout, "Non-fatal error: %s.\n", msg );
     1724  fflush( dbgout );
    16561725}
    16571726
     
    17331802  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
    17341803#ifdef DEBUG
    1735   fprintf(stderr, "0x%x has exception lock\n", tcr);
     1804  fprintf(dbgout, "0x%x has exception lock\n", tcr);
    17361805#endif
    17371806  xf->curr = context;
     
    17491818  tcr->valence = TCR_STATE_EXCEPTION_RETURN;
    17501819#ifdef DEBUG
    1751   fprintf(stderr, "0x%x releasing exception lock\n", tcr);
     1820  fprintf(dbgout, "0x%x releasing exception lock\n", tcr);
    17521821#endif
    17531822  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
     
    17851854#ifdef DARWIN
    17861855  if (running_under_rosetta) {
    1787     fprintf(stderr, "signal handler: signal = %d, pc = 0x%08x\n", signum, xpPC(context));
     1856    fprintf(dbgout, "signal handler: signal = %d, pc = 0x%08x\n", signum, xpPC(context));
    17881857  }
    17891858#endif
     
    19752044      if (disp < (4*node_size)) {
    19762045#if 0
    1977         fprintf(stderr, "pc-luser: finish SP frame in 0x%x, disp = %d\n",tcr, disp);
     2046        fprintf(dbgout, "pc-luser: finish SP frame in 0x%x, disp = %d\n",tcr, disp);
    19782047#endif
    19792048        frame->savevsp = 0;
     
    20302099    } else {
    20312100#ifdef DEBUG
    2032       fprintf(stderr, "tcr 0x%x is past alloc trap, finishing alloc at 0x%x\n", tcr, xpGPR(xp,allocptr));
     2101      fprintf(dbgout, "tcr 0x%x is past alloc trap, finishing alloc at 0x%x\n", tcr, xpGPR(xp,allocptr));
    20332102#endif
    20342103      /* If we're already past the alloc_trap, finish allocating
     
    20372106        finish_allocating_cons(xp);
    20382107#ifdef DEBUG
    2039           fprintf(stderr, "finish allocating cons in TCR = #x%x\n",
     2108          fprintf(dbgout, "finish allocating cons in TCR = #x%x\n",
    20402109                  tcr);
    20412110#endif
     
    20432112        if (allocptr_tag == fulltag_misc) {
    20442113#ifdef DEBUG
    2045           fprintf(stderr, "finish allocating uvector in TCR = #x%x\n",
     2114          fprintf(dbgout, "finish allocating uvector in TCR = #x%x\n",
    20462115                  tcr);
    20472116#endif
     
    20622131    int idx = ((int)((short)(D_field(instr))+fulltag_misc))>>fixnumshift;
    20632132#if 0
    2064         fprintf(stderr, "pc-luser: CATCH frame in 0x%x, idx = %d\n",tcr, idx);
     2133        fprintf(dbgout, "pc-luser: CATCH frame in 0x%x, idx = %d\n",tcr, idx);
    20652134#endif
    20662135
     
    21182187          wait_for_exception_lock_in_handler(tcr, context, &xframe_link);
    21192188#ifdef DEBUG
    2120           fprintf(stderr, "[0x%x acquired exception lock for interrupt]\n",tcr);
     2189          fprintf(dbgout, "[0x%x acquired exception lock for interrupt]\n",tcr);
    21212190#endif
    21222191          PMCL_exception_handler(signum, context, tcr, info, old_valence);
     
    21262195          unlock_exception_lock_in_handler(tcr);
    21272196#ifdef DEBUG
    2128           fprintf(stderr, "[0x%x released exception lock for interrupt]\n",tcr);
     2197          fprintf(dbgout, "[0x%x released exception lock for interrupt]\n",tcr);
    21292198#endif
    21302199          exit_signal_handler(tcr, old_valence);
     
    24442513
    24452514#ifdef DEBUG_MACH_EXCEPTIONS
    2446   fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
     2515  fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr);
    24472516#endif
    24482517  xp = tcr->pending_exception_context;
     
    24562525  }
    24572526#ifdef DEBUG_MACH_EXCEPTIONS
    2458   fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
     2527  fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr);
    24592528#endif
    24602529  return KERN_SUCCESS;
     
    25702639
    25712640#ifdef DEBUG_MACH_EXCEPTIONS
    2572   fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
     2641  fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr);
    25732642#endif
    25742643  pseudosigcontext = create_thread_context_frame(thread, &stackp);
     
    26082677#endif
    26092678#ifdef DEBUG_MACH_EXCEPTIONS
    2610   fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
     2679  fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
    26112680#endif
    26122681  return 0;
     
    27232792
    27242793#ifdef DEBUG_MACH_EXCEPTIONS
    2725   fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
     2794  fprintf(dbgout, "obtaining Mach exception lock in exception thread\n");
    27262795#endif
    27272796
     
    27372806      kret = do_pseudo_sigreturn(thread, tcr);
    27382807#if 0
    2739       fprintf(stderr, "Exception return in 0x%x\n",tcr);
     2808      fprintf(dbgout, "Exception return in 0x%x\n",tcr);
    27402809#endif
    27412810       
     
    27762845                                tcr);
    27772846#if 0
    2778       fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
     2847      fprintf(dbgout, "Setup pseudosignal handling in 0x%x\n",tcr);
    27792848#endif
    27802849
     
    30063075  if ((kret = setup_mach_exception_handling(tcr))
    30073076      != KERN_SUCCESS) {
    3008     fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
     3077    fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret);
    30093078    terminate_lisp();
    30103079  }
     
    30493118        aborted = true;
    30503119      } else {
    3051         fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
     3120        fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread);
    30523121        thread_resume(mach_thread);
    30533122      }
     
    30903159  xp = tcr->suspend_context;
    30913160#ifdef DEBUG_MACH_EXCEPTIONS
    3092   fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
     3161  fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
    30933162          tcr, tcr->pending_exception_context);
    30943163#endif
     
    30963165  restore_mach_thread_state(mach_thread, xp);
    30973166#ifdef DEBUG_MACH_EXCEPTIONS
    3098   fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
     3167  fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
    30993168          tcr, tcr->pending_exception_context);
    31003169#endif
  • branches/working-0711/ccl/lisp-kernel/ppc-gc.c

    r11267 r12198  
    10731073
    10741074#if 0
    1075   fprintf(stderr, "mark VSP range: 0x%lx:0x%lx\n", start, end);
     1075  fprintf(dbgout, "mark VSP range: 0x%lx:0x%lx\n", start, end);
    10761076#endif
    10771077  if (((natural)start) & (sizeof(natural))) {
     
    14241424
    14251425#ifdef DEBUG
    1426   fprintf(stderr,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner);
     1426  fprintf(dbgout,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner);
    14271427#endif
    14281428  if (((natural)p) & sizeof(natural)) {
     
    20642064
    20652065
    2066 int
     2066signed_natural
    20672067purify(TCR *tcr, signed_natural param)
    20682068{
     
    23242324}
    23252325
    2326 int
     2326signed_natural
    23272327impurify(TCR *tcr, signed_natural param)
    23282328{
  • branches/working-0711/ccl/lisp-kernel/ppc-spentry.s

    r11412 r12198  
    14791479       
    14801480_spentry(poweropen_ffcall)
     1481LocalLabelPrefix[]ffcall:               
    14811482        __(mflr loc_pc)
    14821483        __(vpush_saveregs())            /* Now we can use save0-save7 to point to stacks  */
     
    15141515         __(li rcontext,0)
    15151516        __endif
     1517LocalLabelPrefix[]ffcall_setup:
    15161518        __(mtctr nargs)
    15171519        __(ldr(r3,c_frame.param0(sp)))
     
    15261528        /* to the function on entry.  */
    15271529        __(mr r12,nargs)
     1530LocalLabelPrefix[]ffcall_setup_end:
     1531LocalLabelPrefix[]ffcall_call:
    15281532        __(bctrl)
    1529         __(b FF_call_return_common)
     1533LocalLabelPrefix[]ffcall_call_end:
     1534        /* C should have preserved save0 (= rcontext) for us.  */
     1535        __(ldr(sp,0(sp)))
     1536        __(mr imm2,save0)
     1537        __(ldr(vsp,lisp_frame.savevsp(sp)))
     1538        __(li rzero,0)
     1539        __(mr loc_pc,rzero)
     1540        __(li arg_x,nil_value)
     1541        __(li arg_y,nil_value)
     1542        __(li arg_z,nil_value)
     1543        __(li temp0,nil_value)
     1544        __(li temp1,nil_value)
     1545        __(li temp2,nil_value)
     1546        __(li temp3,nil_value)
     1547        __(li fn,nil_value)
     1548        __(mr rcontext,imm2)
     1549        __(li imm2,TCR_STATE_LISP)
     1550        __(ldr(tsp,tcr.save_tsp(rcontext)))
     1551        __(li save0,0)
     1552        __(li save1,0)
     1553        __(li save2,0)
     1554        __(li save3,0)
     1555        __(li save4,0)
     1556        __(li save5,0)
     1557        __(li save6,0)
     1558        __(li save7,0)
     1559        __(li allocptr,-dnode_size)
     1560        __(li allocbase,-dnode_size)
     1561        __(str(imm2,tcr.valence(rcontext)))     
     1562        __(vpop_saveregs())
     1563        __(ldr(allocptr,tcr.save_allocptr(rcontext)))
     1564        __(ldr(allocbase,tcr.save_allocbase(rcontext)))
     1565        __(ldr(loc_pc,lisp_frame.savelr(sp)))
     1566        __(mtlr loc_pc)
     1567        __(ldr(fn,lisp_frame.savefn(sp)))
     1568        __(mffs f0)
     1569        __(stfd f0,8(sp))
     1570        __(lwz imm3,12(sp))     /* imm3 = FPSCR after call  */
     1571        __(clrrwi imm2,imm3,8)
     1572        __(discard_lisp_frame())
     1573        __(str(imm2,tcr.ffi_exception(rcontext)))
     1574        __(lfd f0,tcr.lisp_fpscr(rcontext))
     1575        __(mtfsf 0xff,f0)
     1576        __(check_pending_interrupt([cr1]))
     1577        __(mtxer rzero)
     1578        __(mtctr rzero)
     1579        __(blr)
     1580
    15301581
    15311582/* Just like poweropen_ffcall, only we save all argument(result)
     
    16041655        __(stfd f12,((8*node_size)+(11*8))(save7))
    16051656        __(stfd f13,((8*node_size)+(12*8))(save7))
    1606         __(b FF_call_return_common)
     1657        /* C should have preserved save0 (= rcontext) for us.  */
     1658        __(ldr(sp,0(sp)))
     1659        __(mr imm2,save0)
     1660        __(ldr(vsp,lisp_frame.savevsp(sp)))
     1661        __(li rzero,0)
     1662        __(mr loc_pc,rzero)
     1663        __(li arg_x,nil_value)
     1664        __(li arg_y,nil_value)
     1665        __(li arg_z,nil_value)
     1666        __(li temp0,nil_value)
     1667        __(li temp1,nil_value)
     1668        __(li temp2,nil_value)
     1669        __(li temp3,nil_value)
     1670        __(li fn,nil_value)
     1671        __(mr rcontext,imm2)
     1672        __(li imm2,TCR_STATE_LISP)
     1673        __(ldr(tsp,tcr.save_tsp(rcontext)))
     1674        __(li save0,0)
     1675        __(li save1,0)
     1676        __(li save2,0)
     1677        __(li save3,0)
     1678        __(li save4,0)
     1679        __(li save5,0)
     1680        __(li save6,0)
     1681        __(li save7,0)
     1682        __(li allocptr,-dnode_size)
     1683        __(li allocbase,-dnode_size)
     1684        __(str(imm2,tcr.valence(rcontext)))     
     1685        __(vpop_saveregs())
     1686        __(ldr(allocptr,tcr.save_allocptr(rcontext)))
     1687        __(ldr(allocbase,tcr.save_allocbase(rcontext)))
     1688        __(ldr(loc_pc,lisp_frame.savelr(sp)))
     1689        __(mtlr loc_pc)
     1690        __(ldr(fn,lisp_frame.savefn(sp)))
     1691        __(mffs f0)
     1692        __(stfd f0,8(sp))
     1693        __(lwz imm3,12(sp))     /* imm3 = FPSCR after call  */
     1694        __(clrrwi imm2,imm3,8)
     1695        __(discard_lisp_frame())
     1696        __(str(imm2,tcr.ffi_exception(rcontext)))
     1697        __(lfd f0,tcr.lisp_fpscr(rcontext))
     1698        __(mtfsf 0xff,f0)
     1699        __(check_pending_interrupt([cr1]))
     1700        __(mtxer rzero)
     1701        __(mtctr rzero)
     1702        __(blr)
     1703
    16071704
    16081705               
     
    16561753        __(b _SPheap_cons_rest_arg)
    16571754
    1658 
    1659 _spentry(poweropen_callbackX)       
    1660         /* Save C argument registers  */
    1661         __(str(r3,c_frame.param0(sp)))
    1662         __(str(r4,c_frame.param1(sp)))
    1663         __(str(r5,c_frame.param2(sp)))
    1664         __(str(r6,c_frame.param3(sp)))
    1665         __(str(r7,c_frame.param4(sp)))
    1666         __(str(r8,c_frame.param5(sp)))
    1667         __(str(r9,c_frame.param6(sp)))
    1668         __(str(r10,c_frame.param7(sp)))
    1669         __(mflr imm3)
    1670         __(str(imm3,c_frame.savelr(sp)))
    1671         __(mfcr imm0)
    1672         __(str(imm0,c_frame.crsave(sp)))
    1673 
    1674         /* Save the non-volatile registers on the sp stack  */
    1675         /* This is a non-standard stack frame, but noone will ever see it,  */
    1676         /* so it doesn't matter. It will look like more of the stack  */
    1677         /* frame pushed below.  */
    1678         __(stru(sp,-(stack_align(c_reg_save.size))(sp)))
    1679         __(str(r13,c_reg_save.save_gprs+(0*node_size)(sp)))
    1680         __(str(r14,c_reg_save.save_gprs+(1*node_size)(sp)))
    1681         __(str(r15,c_reg_save.save_gprs+(2*node_size)(sp)))
    1682         __(str(r16,c_reg_save.save_gprs+(3*node_size)(sp)))
    1683         __(str(r17,c_reg_save.save_gprs+(4*node_size)(sp)))
    1684         __(str(r18,c_reg_save.save_gprs+(5*node_size)(sp)))
    1685         __(str(r19,c_reg_save.save_gprs+(6*node_size)(sp)))
    1686         __(str(r20,c_reg_save.save_gprs+(7*node_size)(sp)))
    1687         __(str(r21,c_reg_save.save_gprs+(8*node_size)(sp)))
    1688         __(str(r22,c_reg_save.save_gprs+(9*node_size)(sp)))
    1689         __(str(r23,c_reg_save.save_gprs+(10*node_size)(sp)))
    1690         __(str(r24,c_reg_save.save_gprs+(11*node_size)(sp)))
    1691         __(str(r25,c_reg_save.save_gprs+(12*node_size)(sp)))
    1692         __(str(r26,c_reg_save.save_gprs+(13*node_size)(sp)))
    1693         __(str(r27,c_reg_save.save_gprs+(14*node_size)(sp)))
    1694         __(str(r28,c_reg_save.save_gprs+(15*node_size)(sp)))
    1695         __(str(r29,c_reg_save.save_gprs+(16*node_size)(sp)))
    1696         __(str(r30,c_reg_save.save_gprs+(17*node_size)(sp)))
    1697         __(str(r31,c_reg_save.save_gprs+(18*node_size)(sp)))
    1698         __(stfd f1,c_reg_save.save_fprs+(0*8)(sp))
    1699         __(stfd f2,c_reg_save.save_fprs+(1*8)(sp))
    1700         __(stfd f3,c_reg_save.save_fprs+(2*8)(sp))
    1701         __(stfd f4,c_reg_save.save_fprs+(3*8)(sp))
    1702         __(stfd f5,c_reg_save.save_fprs+(4*8)(sp))
    1703         __(stfd f6,c_reg_save.save_fprs+(5*8)(sp))
    1704         __(stfd f7,c_reg_save.save_fprs+(6*8)(sp))
    1705         __(stfd f8,c_reg_save.save_fprs+(7*8)(sp))
    1706         __(stfd f9,c_reg_save.save_fprs+(8*8)(sp))
    1707         __(stfd f10,c_reg_save.save_fprs+(9*8)(sp))
    1708         __(stfd f11,c_reg_save.save_fprs+(10*8)(sp))
    1709         __(stfd f12,c_reg_save.save_fprs+(11*8)(sp))
    1710         __(stfd f13,c_reg_save.save_fprs+(12*8)(sp))
    1711         __(check_stack_alignment(r0))
    1712         __(mffs f0)
    1713         __(stfd f0,c_reg_save.save_fp_zero(sp))
    1714         __(ldr(r31,c_reg_save.save_fp_zero+4(sp)))      /* recover FPSCR image  */
    1715         __(str(r31,c_reg_save.save_fpscr(sp)))
    1716         __(lwi(r30,0x43300000))
    1717         __(lwi(r31,0x80000000))
    1718         __(stw r30,c_reg_save.save_fp_zero(sp))
    1719         __(stw r31,c_reg_save.save_fp_zero+4(sp))
    1720         __(stfd fp_s32conv,c_reg_save.save_fps32conv(sp))
    1721         __(lfd fp_s32conv,c_reg_save.save_fp_zero(sp))
    1722         __(stfd fp_zero,c_reg_save.save_fp_zero(sp))
    1723         __(lfs fp_zero,lisp_globals.short_float_zero(0))        /* ensure that fp_zero contains 0.0  */
    1724 
    1725 /* Restore rest of Lisp context.  */
    1726 /* Could spread out the memory references here to gain a little speed  */
    1727 
    1728         __(li loc_pc,0)
    1729         __(li fn,0)                     /* subprim, not a lisp function  */
    1730         __(li temp3,0)
    1731         __(li temp2,0)
    1732         __(li temp1,0)
    1733         __(li temp0,0)
    1734         __(li arg_x,0)
    1735         __(box_fixnum(arg_y,r11))       /* callback-index  */
    1736         __(la arg_z,c_reg_save.save_fprs(sp))
    1737         __(str(arg_z,stack_align(c_reg_save.size)+c_frame.unused(sp)))
    1738         __(la arg_z,stack_align(c_reg_save.size)+c_frame.param0(sp))    /* parameters (tagged as a fixnum)  */
    1739 
    1740         /* Recover lisp thread context. Have to call C code to do so.  */
    1741         __(ref_global(r12,get_tcr))
    1742         __(mtctr r12)
    1743         __(li r3,1)
    1744         __(stru(sp,-(stack_align(c_frame.minsiz))(sp)))
    1745         __(bctrl)
    1746         __(la rcontext,TCR_BIAS(r3))
    1747         /* re-establish lisp exception handling  */
    1748         __(ref_global(r12,lisp_return_hook))
    1749         __(mtctr r12)
    1750         __(bctrl)
    1751         __(la sp,(stack_align(c_frame.minsiz))(sp))
    1752 
    1753         __(ldr(vsp,tcr.save_vsp(rcontext)))
    1754         __(ldr(tsp,tcr.save_tsp(rcontext)))             
    1755         __(li rzero,0)
    1756         __(mtxer rzero) /* lisp wants the overflow bit clear  */
    1757         __(mtctr rzero)
    1758         __(li imm0,TCR_STATE_LISP)
    1759         __(li save0,0)
    1760         __(li save1,0)
    1761         __(li save2,0)
    1762         __(li save3,0)
    1763         __(li save4,0)
    1764         __(li save5,0)
    1765         __(li save6,0)
    1766         __(li save7,0)
    1767         __(lfd f0,tcr.lisp_fpscr(rcontext))
    1768         __(mtfsf 0xff,f0)
    1769         __(li allocptr,0)
    1770         __(li allocbase,0)
    1771         __(str(imm0,tcr.valence(rcontext)))
    1772         __(ldr(allocptr,tcr.save_allocptr(rcontext)))
    1773         __(ldr(allocbase,tcr.save_allocbase(rcontext)))
    1774        
    1775         __(restore_saveregs(vsp))
    1776         /* load nargs and callback to the lisp  */
    1777         __(set_nargs(2))
    1778         __(ldr(imm2,tcr.cs_area(rcontext)))
    1779         __(ldr(imm4,area.active(imm2)))
    1780         __(stru(imm4,-lisp_frame.size(sp)))
    1781         __(str(imm3,lisp_frame.savelr(sp)))
    1782         __(li fname,nrs.callbacks)      /* %pascal-functions%  */
    1783         __(call_fname)
    1784         __(ldr(imm2,lisp_frame.backlink(sp)))
    1785         __(ldr(imm3,tcr.cs_area(rcontext)))
    1786         __(str(imm2,area.active(imm3)))
    1787         __(discard_lisp_frame())
    1788         /* save_vsp will be restored from ff_call's stack frame, but  */
    1789         /* I included it here for consistency.  */
    1790         /* save_tsp is set below after we exit Lisp context.  */
    1791         __(str(allocptr,tcr.save_allocptr(rcontext)))
    1792         __(str(allocbase,tcr.save_allocbase(rcontext)))
    1793         __(str(vsp,tcr.save_vsp(rcontext)))
    1794         __(str(tsp,tcr.save_tsp(rcontext)))
    1795 
    1796         __(li imm1,TCR_STATE_FOREIGN)
    1797         __(str(imm1,tcr.valence(rcontext)))
    1798         __(mr r3,rcontext)
    1799         __(ldr(r4,tcr.foreign_exception_status(rcontext)))
    1800         __(cmpri(r4,0))
    1801         /* Restore the non-volatile registers & fpscr  */
    1802         __(lfd fp_zero,c_reg_save.save_fp_zero(sp))
    1803         __(ldr(r31,c_reg_save.save_fpscr(sp)))
    1804         __(str(r31,c_reg_save.save_fp_zero+4(sp)))
    1805         __(lfd f0,c_reg_save.save_fp_zero(sp))
    1806         __(mtfsf 0xff,f0)
    1807         __(ldr(r13,c_reg_save.save_gprs+(0*node_size)(sp)))
    1808         __(ldr(r14,c_reg_save.save_gprs+(1*node_size)(sp)))
    1809         __(ldr(r15,c_reg_save.save_gprs+(2*node_size)(sp)))
    1810         __(ldr(r16,c_reg_save.save_gprs+(3*node_size)(sp)))
    1811         __(ldr(r17,c_reg_save.save_gprs+(4*node_size)(sp)))
    1812         __(ldr(r18,c_reg_save.save_gprs+(5*node_size)(sp)))
    1813         __(ldr(r19,c_reg_save.save_gprs+(6*node_size)(sp)))
    1814         __(ldr(r20,c_reg_save.save_gprs+(7*node_size)(sp)))
    1815         __(ldr(r21,c_reg_save.save_gprs+(8*node_size)(sp)))
    1816         __(ldr(r22,c_reg_save.save_gprs+(9*node_size)(sp)))
    1817         __(ldr(r23,c_reg_save.save_gprs+(10*node_size)(sp)))
    1818         __(ldr(r24,c_reg_save.save_gprs+(11*node_size)(sp)))
    1819         __(ldr(r25,c_reg_save.save_gprs+(12*node_size)(sp)))
    1820         __(ldr(r26,c_reg_save.save_gprs+(13*node_size)(sp)))
    1821         __(ldr(r27,c_reg_save.save_gprs+(14*node_size)(sp)))
    1822         __(ldr(r28,c_reg_save.save_gprs+(15*node_size)(sp)))
    1823         __(ldr(r29,c_reg_save.save_gprs+(16*node_size)(sp)))
    1824         __(ldr(r30,c_reg_save.save_gprs+(17*node_size)(sp)))
    1825         __(ldr(r31,c_reg_save.save_gprs+(18*node_size)(sp)))
    1826         __(lfd fp_s32conv,c_reg_save.save_fps32conv(sp))
    1827         __(beq 9f)
    1828         __(ref_global(r12,lisp_exit_hook))
    1829         __(mtctr r12)
    1830         __(bctrl)
    1831 9:
    1832         __(lfd f1,c_reg_save.save_fprs+(0*8)(sp))
    1833         __(lfd f2,c_reg_save.save_fprs+(1*8)(sp))
    1834         __(lfd f3,c_reg_save.save_fprs+(2*8)(sp))
    1835         __(lfd f4,c_reg_save.save_fprs+(3*8)(sp))
    1836         __(lfd f5,c_reg_save.save_fprs+(4*8)(sp))
    1837         __(lfd f6,c_reg_save.save_fprs+(5*8)(sp))
    1838         __(lfd f7,c_reg_save.save_fprs+(6*8)(sp))
    1839         __(lfd f8,c_reg_save.save_fprs+(7*8)(sp))
    1840         __(lfd f9,c_reg_save.save_fprs+(8*8)(sp))
    1841         __(lfd f10,c_reg_save.save_fprs+(9*8)(sp))
    1842         __(lfd f11,c_reg_save.save_fprs+(10*8)(sp))
    1843         __(lfd f12,c_reg_save.save_fprs+(11*8)(sp))
    1844         __(lfd f13,c_reg_save.save_fprs+(12*8)(sp))
    1845         __(ldr(sp,0(sp)))
    1846         __(ldr(r3,c_frame.param0(sp)))
    1847         __(ldr(r4,c_frame.param1(sp)))
    1848         __(ldr(r5,c_frame.param2(sp)))
    1849         __(ldr(r6,c_frame.param3(sp)))
    1850         __(ldr(r7,c_frame.param4(sp)))
    1851         __(ldr(r8,c_frame.param5(sp)))
    1852         __(ldr(r9,c_frame.param6(sp)))
    1853         __(ldr(r10,c_frame.param7(sp)))
    1854         __(ldr(r11,c_frame.savelr(sp)))
    1855         __(mtlr r11)
    1856         __(ldr(r12,c_frame.crsave(sp)))
    1857         __(mtcr r12)
    1858         __(blr)
     1755/* This was trying to swap exception ports to work around Darwin JNI lossage.
     1756   It's tended to bitrot, and we have another way to do that now.
     1757*/       
     1758_spentry(poweropen_callbackX)
     1759        .long 0x7c800008        /* debug trap */
    18591760       
    18601761/* Prepend all but the first two (closure code, fn) and last two  */
     
    32523153/* almost exactly as above, but "swap exception handling info" */
    32533154/* on exit and return  */
     3155/* Deprecated */       
    32543156_spentry(poweropen_ffcallX)
    3255         __(mflr loc_pc)
    3256         __(vpush_saveregs())            /* Now we can use save0-save7 to point to stacks  */
    3257         __(mr save0,rcontext)   /* or address globals.  */
    3258         __(extract_typecode(imm0,arg_z))
    3259         __(cmpri(cr7,imm0,subtag_macptr))
    3260         __(ldr(save1,c_frame.backlink(sp)))     /* bottom of reserved lisp frame  */
    3261         __(la save2,-lisp_frame.size(save1))    /* top of lisp frame */
    3262         __(zero_doublewords save2,0,lisp_frame.size)
    3263         __(str(save1,lisp_frame.backlink(save2)))
    3264         __(str(save2,c_frame.backlink(sp)))
    3265         __(str(fn,lisp_frame.savefn(save2)))
    3266         __(str(loc_pc,lisp_frame.savelr(save2)))
    3267         __(str(vsp,lisp_frame.savevsp(save2)))
    3268         __(bne cr7,1f)
    3269         __(ldr(arg_z,macptr.address(arg_z)))
    3270 1:
    3271         __(ldr(save3,tcr.cs_area(rcontext)))
    3272         __(str(save2,area.active(save3)))
    3273         __(str(allocptr,tcr.save_allocptr(rcontext)))
    3274         __(str(allocbase,tcr.save_allocbase(rcontext)))
    3275         __(str(tsp,tcr.save_tsp(rcontext)))
    3276         __(str(vsp,tcr.save_vsp(rcontext)))
    3277         __(str(rzero,tcr.ffi_exception(rcontext)))
    3278         __(mffs f0)
    3279         __(stfd f0,tcr.lisp_fpscr(rcontext))    /* remember lisp's fpscr  */
    3280         __(mtfsf 0xff,fp_zero)  /* zero foreign fpscr  */
    3281         __(ldr(r3,tcr.foreign_exception_status(rcontext)))
    3282         __(cmpri(r3,0))
    3283         __(ref_global(r12,lisp_exit_hook))
    3284         __(mtctr r12)
    3285         __(beq+ 1f)
    3286         __(stru(sp,-(stack_align(c_frame.minsiz))(sp)))
    3287         __(bctrl)
    3288         __(la sp,(stack_align(c_frame.minsiz))(sp))
    3289 1:     
    3290         __(li rcontext,0)
    3291         __(mtctr arg_z)
    3292         __(ldr(r3,c_frame.param0(sp)))
    3293         __(ldr(r4,c_frame.param1(sp)))
    3294         __(ldr(r5,c_frame.param2(sp)))
    3295         __(ldr(r6,c_frame.param3(sp)))
    3296         __(ldr(r7,c_frame.param4(sp)))
    3297         __(ldr(r8,c_frame.param5(sp)))
    3298         __(ldr(r9,c_frame.param6(sp)))
    3299         __(ldr(r10,c_frame.param7(sp)))
    3300         /* Darwin is allegedly very picky about what register points */
    3301         /* to the function on entry.  */
    3302         __(mr r12,arg_z)
    3303         __(bctrl)
    3304         __(ref_global(r12,lisp_return_hook))
    3305         __(mtctr r12)
    3306         __(str(r3,c_frame.param0(sp)))
    3307         __(str(r4,c_frame.param1(sp)))
    3308         __(stfd f1,c_frame.param2(sp))
    3309         __(stru(sp,-(stack_align(c_frame.minsiz))(sp)))
    3310         __(mr r3,save0)
    3311         __(bctrl)
    3312         __(la sp,(stack_align(c_frame.minsiz))(sp))
    3313         __(ldr(r3,c_frame.param0(sp)))
    3314         __(ldr(r4,c_frame.param1(sp)))
    3315         __(lfd f1,c_frame.param2(sp))
    3316         __(b FF_call_return_common)     
    3317        
     3157        .long 0x7c800008        /* debug trap */
    33183158
    33193159
     
    58335673        __(crset 6)
    58345674        __(bctrl)
    5835         _endsubp(eabi_ff_call)
    5836        
    5837         _startfn(FF_call_return_common)
    58385675        /* C should have preserved save0 (= rcontext) for us.  */
    58395676        __(ldr(sp,0(sp)))
     
    58645701        __(li allocbase,-dnode_size)
    58655702        __(str(imm2,tcr.valence(rcontext)))     
    5866         .globl C(ffcall_return_window)
    5867 C(ffcall_return_window):               
    58685703        __(vpop_saveregs())
    58695704        __(ldr(allocptr,tcr.save_allocptr(rcontext)))
    58705705        __(ldr(allocbase,tcr.save_allocbase(rcontext)))
    5871         .globl C(ffcall_return_window_end)
    5872 C(ffcall_return_window_end):               
    58735706        __(ldr(loc_pc,lisp_frame.savelr(sp)))
    58745707        __(mtlr loc_pc)
  • branches/working-0711/ccl/lisp-kernel/ppc-spjump.s

    r10944 r12198  
    2525         .org 0x5000-0x2000
    2626        /*      .align 12 */
    27         __ifdef([DARWIN])
    28          __ifdef([PPC64])
    2927         .globl C(spjump_start)
    3028C(spjump_start):
    31          __endif
    32        __endif
    3329        _spjump(jmpsym)
    3430        _spjump(jmpnfn)
     
    184180        _spjump(bind_interrupt_level_0)
    185181        _spjump(progvrestore)
    186         __ifdef([DARWIN])
    187          __ifdef([PPC64])
    188182          .globl C(spjump_end)
    189183C(spjump_end):
    190          .org 0x5000-0x1000
    191          __endif
    192         __endif
     184        __ifdef([DARWIN])
     185         __ifdef([PPC64])
     186           .org 0x5000-0x1000
     187         __endif
     188        __endif
    193189        _endfile
    194190       
  • branches/working-0711/ccl/lisp-kernel/thread_manager.c

    r11507 r12198  
    2626
    2727#ifdef HAVE_TLS
    28 __thread TCR __attribute__ ((aligned (16))) current_tcr;
     28__thread char tcrbuf[sizeof(TCR)+16];
     29__thread TCR *current_tcr;
    2930#endif
    3031
     
    4950extern pc spentry_start, spentry_end,subprims_start,subprims_end;
    5051extern pc restore_windows_context_start, restore_windows_context_end,
    51   restore_windows_context_load_rcx, restore_windows_context_iret;
     52  restore_windows_context_iret;
     53
    5254
    5355extern void interrupt_handler(int, siginfo_t *, ExceptionInformation *);
     
    5961 
    6062BOOL (*pCancelIoEx)(HANDLE, OVERLAPPED*) = NULL;
    61 
    62   ;
     63BOOL (*pCancelSynchronousIo)(HANDLE) = NULL;
     64
    6365
    6466
     
    117119      }
    118120    }
     121    if (pCancelSynchronousIo) {
     122      pCancelSynchronousIo(hthread);
     123    }
    119124    QueueUserAPC(nullAPC, hthread, 0);
    120125    ResumeThread(hthread);
     
    570575#endif
    571576  TCR *tcr = get_interrupt_tcr(false);
    572 
     577 
     578  if (tcr == NULL) {
     579    /* Got a suspend signal sent to the pthread. */
     580    extern natural initial_stack_size;
     581    void register_thread_tcr(TCR *);
     582   
     583    tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
     584    tcr->suspend_count = 1;
     585    tcr->vs_area->active -= node_size;
     586    *(--tcr->save_vsp) = lisp_nil;
     587    register_thread_tcr(tcr);
     588  }
    573589  if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<<fixnumshift)) {
    574590    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
     
    822838    }
    823839#endif
    824     for (next = chain; next;) {
    825       next = next->next;
     840    for (;chain;chain = next) {
     841      next = chain->next;
    826842      free(chain);
    827843    }
     
    956972  if (i == LDT_ENTRIES) {
    957973    pthread_mutex_unlock(&ldt_lock);
    958     fprintf(stderr, "All 8192 ldt entries in use ?\n");
     974    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
    959975    _exit(1);
    960976  }
     
    965981  if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) {
    966982    pthread_mutex_unlock(&ldt_lock);
    967     fprintf(stderr,"Can't assign LDT entry\n");
     983    fprintf(dbgout,"Can't assign LDT entry\n");
    968984    _exit(1);
    969985  }
     
    10281044
    10291045  if (status) {
    1030     fprintf(stderr, "This application can't run under this OS version\n");
     1046    fprintf(dbgout, "This application can't run under this OS version\n");
    10311047    _exit(1);
    10321048  }
     
    10621078  if (i == 8192) {
    10631079    ReleaseMutex(ldt_lock);
    1064     fprintf(stderr, "All 8192 ldt entries in use ?\n");
     1080    fprintf(dbgout, "All 8192 ldt entries in use ?\n");
    10651081    _exit(1);
    10661082  }
     
    11001116free_tcr_extra_segment(TCR *tcr)
    11011117{
     1118  win32_ldt_info info;
     1119  LDT_ENTRY *entry = &(info.entry);
     1120  DWORD *words = (DWORD *)entry;
     1121  int idx = tcr->ldt_selector >> 3;
     1122
     1123
     1124  info.offset = idx << 3;
     1125  info.size = sizeof(LDT_ENTRY);
     1126
     1127  words[0] = 0;
     1128  words[1] = 0;
     1129
     1130  WaitForSingleObject(ldt_lock,INFINITE);
     1131  NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info));
     1132  clr_bit(ldt_entries_in_use,idx);
     1133  ReleaseMutex(ldt_lock);
     1134
     1135  tcr->ldt_selector = 0;
    11021136}
    11031137
     
    11431177  }
    11441178#else
     1179  extern unsigned short get_fs_register(void);
     1180
    11451181  if (i386_set_fsbase((void*)tcr)) {
    11461182    perror("i386_set_fsbase");
    11471183    exit(1);
    11481184  }
     1185
     1186
    11491187  /* Once we've called i386_set_fsbase, we can't write to %fs. */
    11501188  tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL);
     
    12201258  }
    12211259  pthread_mutex_unlock(&ldt_lock);
    1222   fprintf(stderr, "All 8192 LDT descriptors in use\n");
     1260  fprintf(dbgout, "All 8192 LDT descriptors in use\n");
    12231261  _exit(1);
    12241262
     
    12691307
    12701308#ifdef HAVE_TLS
    1271   TCR *tcr = &current_tcr;
     1309  TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15));
     1310  current_tcr = tcr;
    12721311#else /* no TLS */
    12731312  TCR *tcr = allocate_tcr();
     
    15931632  lisp_global(TCR_KEY) = TlsAlloc();
    15941633  pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx");
     1634  pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo");
    15951635#else
    15961636  pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr);
     
    16141654  thread_activation *activation = (thread_activation *)param;
    16151655  TCR *tcr = new_tcr(activation->vsize, activation->tsize);
     1656  LispObj *start_vsp;
    16161657#ifndef WINDOWS
    16171658  sigset_t mask, old_mask;
     
    16281669  tcr->vs_area->active -= node_size;
    16291670  *(--tcr->save_vsp) = lisp_nil;
     1671  start_vsp = tcr->save_vsp;
    16301672  enable_fp_exceptions();
    16311673  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
     
    16371679    /* Now go run some lisp code */
    16381680    start_lisp(TCR_TO_TSD(tcr),0);
     1681    tcr->save_vsp = start_vsp;
    16391682  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
    16401683#ifndef WINDOWS
     
    16471690#else
    16481691  return NULL;
     1692#endif
     1693}
     1694
     1695typedef
     1696short (*suspendf)();
     1697
     1698
     1699void
     1700suspend_current_cooperative_thread()
     1701{
     1702  static suspendf cooperative_suspend = NULL;
     1703  void *xFindSymbol(void*,char*);
     1704
     1705  if (cooperative_suspend == NULL) {
     1706    cooperative_suspend = (suspendf)xFindSymbol(NULL, "SetThreadState");
     1707  }
     1708  if (cooperative_suspend) {
     1709    cooperative_suspend(1 /* kCurrentThreadID */,
     1710                        1 /* kStoppedThreadState */,
     1711                        0 /* kAnyThreadID */);
     1712  }
     1713}
     1714
     1715void *
     1716cooperative_thread_startup(void *arg)
     1717{
     1718
     1719  TCR *tcr = get_tcr(0);
     1720  LispObj *start_vsp;
     1721
     1722  if (!tcr) {
     1723    return NULL;
     1724  }
     1725#ifndef WINDOWS
     1726  pthread_cleanup_push(tcr_cleanup,(void *)tcr);
     1727#endif
     1728  SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET);
     1729  start_vsp = tcr->save_vsp;
     1730  do {
     1731    SEM_RAISE(tcr->reset_completion);
     1732    suspend_current_cooperative_thread();
     1733     
     1734    start_lisp(tcr, 0);
     1735    tcr->save_vsp = start_vsp;
     1736  } while (tcr->flags & (1<<TCR_FLAG_BIT_AWAITING_PRESET));
     1737#ifndef WINDOWS
     1738  pthread_cleanup_pop(true);
     1739#else
     1740  tcr_cleanup(tcr);
    16491741#endif
    16501742}
     
    17551847  pthread_attr_t attr;
    17561848  pthread_t returned_thread = (pthread_t) 0;
     1849  TCR *current = get_tcr(true);
    17571850
    17581851  pthread_attr_init(&attr);
     
    17771870  /*
    17781871     I think that's just about enough ... create the thread.
     1872     Well ... not quite enough.  In Leopard (at least), many
     1873     pthread routines grab an internal spinlock when validating
     1874     their arguments.  If we suspend a thread that owns this
     1875     spinlock, we deadlock.  We can't in general keep that
     1876     from happening: if arbitrary C code is suspended while
     1877     it owns the spinlock, we still deadlock.  It seems that
     1878     the best that we can do is to keep -this- code from
     1879     getting suspended (by grabbing TCR_AREA_LOCK)
    17791880  */
     1881  LOCK(lisp_global(TCR_AREA_LOCK),current);
    17801882  pthread_create(&returned_thread, &attr, start_routine, param);
     1883  UNLOCK(lisp_global(TCR_AREA_LOCK),current);
    17811884  pthread_attr_destroy(&attr);
    17821885  return (LispObj) ptr_to_lispobj(returned_thread);
     
    17881891{
    17891892#ifdef HAVE_TLS
    1790   TCR *current = current_tcr.linear;
     1893  TCR *current = current_tcr;
    17911894#else
    17921895  void *tsd = (void *)tsd_get(lisp_global(TCR_KEY));
     
    17981901      callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address;
    17991902    int i, nbindwords = 0;
    1800     extern unsigned initial_stack_size;
     1903    extern natural initial_stack_size;
    18011904   
    18021905    /* Make one. */
     
    18061909#ifdef DEBUG_TCR_CREATION
    18071910#ifndef WINDOWS
    1808     fprintf(stderr, "\ncreating TCR for pthread 0x%x", pthread_self());
     1911    fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self());
    18091912#endif
    18101913#endif
     
    18381941
    18391942#ifdef WINDOWS
     1943void *
     1944pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where)
     1945{
     1946  /* Thread has started to return from an exception. */
     1947  if (where < restore_windows_context_iret) {
     1948    /* In the process of restoring registers; context still in
     1949       %rcx.  Just make our suspend_context be the context
     1950       we're trying to restore, so that we'll resume from
     1951       the suspend in the same context that we're trying to
     1952       restore */
     1953#ifdef WIN_64
     1954    *pcontext = * (CONTEXT *)(pcontext->Rcx);
     1955#else
     1956    *pcontext = * (CONTEXT *)(pcontext->Ecx);
     1957#endif
     1958  } else {
     1959    /* Most of the context has already been restored; fix %rcx
     1960       if need be, then restore ss:rsp, cs:rip, and flags. */
     1961#ifdef WIN_64
     1962    x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
     1963
     1964    pcontext->Rip = iret_frame->Rip;
     1965    pcontext->SegCs = (WORD) iret_frame->Cs;
     1966    pcontext->EFlags = (DWORD) iret_frame->Rflags;
     1967    pcontext->Rsp = iret_frame->Rsp;
     1968    pcontext->SegSs = (WORD) iret_frame->Ss;
     1969#else
     1970    ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp);
     1971
     1972    pcontext->Eip = iret_frame->Eip;
     1973    pcontext->SegCs = (WORD) iret_frame->Cs;
     1974    pcontext->EFlags = (DWORD) iret_frame->EFlags;
     1975    pcontext->Esp += sizeof(ia32_iret_frame);
     1976#endif
     1977  }
     1978  tcr->pending_exception_context = NULL;
     1979}
    18401980
    18411981Boolean
     
    18692009      if ((where >= restore_windows_context_start) &&
    18702010          (where < restore_windows_context_end)) {
    1871         /* Thread has started to return from an exception. */
    1872         if (where < restore_windows_context_load_rcx) {
    1873           /* In the process of restoring registers; context still in
    1874              %rcx.  Just make our suspend_context be the context
    1875              we're trying to restore, so that we'll resume from
    1876              the suspend in the same context that we're trying to
    1877              restore */
    1878 #ifdef WIN_64
    1879           *pcontext = * (CONTEXT *)(pcontext->Rcx);
    1880 #else
    1881           fprintf(stderr, "missing win32 suspend code, case (1)\n");
    1882 #endif
    1883         } else {
    1884           /* Most of the context has already been restored; fix %rcx
    1885              if need be, then restore ss:rsp, cs:rip, and flags. */
    1886 #ifdef WIN64
    1887           x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp);
    1888           if (where == restore_windows_context_load_rcx) {
    1889             pcontext->Rcx = ((CONTEXT*)(pcontext->Rcx))->Rcx;
    1890           }
    1891           pcontext->Rip = iret_frame->Rip;
    1892           pcontext->SegCs = (WORD) iret_frame->Cs;
    1893           pcontext->EFlags = (DWORD) iret_frame->Rflags;
    1894           pcontext->Rsp = iret_frame->Rsp;
    1895           pcontext->SegSs = (WORD) iret_frame->Ss;
    1896 #else
    1897 #warning need context setup for win32
    1898           fprintf(stderr, "missing win32 suspend code, case (2)\n");
    1899 #endif
    1900         }
    1901         tcr->suspend_context = NULL;
     2011        pc_luser_restore_windows_context(pcontext, tcr, where);
    19022012      } else {
    19032013        area *ts = tcr->ts_area;
  • branches/working-0711/ccl/lisp-kernel/windows-calls.c

    r11497 r12198  
    169169    errno = ENOMEM;
    170170    break;
     171  case ERROR_OPERATION_ABORTED:
     172    errno = EINTR;
     173    break;
    171174  default:
    172175    errno = EINVAL;
     
    257260
    258261int
     262wopen(wchar_t *path, int flag, int mode)
     263{
     264  HANDLE h = lisp_open(path, flag, mode);
     265
     266  if (h == (HANDLE)-1) {
     267    return -1;                  /* errno already set */
     268  }
     269  return _open_osfhandle((DWORD)h,0);
     270}
     271
     272int
    259273lisp_close(HANDLE hfile)
    260274{
     
    295309    return nread;
    296310  }
     311
    297312  err = GetLastError();
    298313 
     
    336351  case ERROR_HANDLE_EOF:
    337352    return 0;
    338   case ERROR_OPERATION_ABORTED:
    339     errno = EINTR;
    340     return -1;
    341353  default:
    342354    _dosmaperr(err);
     
    350362  HANDLE hevent;
    351363  OVERLAPPED overlapped;
    352   DWORD err, nwritten;
     364  DWORD err, nwritten, wait_result;
     365  pending_io pending;
    353366  TCR *tcr = (TCR *)get_tcr(1);
    354367
     
    367380  }
    368381
     382
     383  pending.h = hfile;
     384  pending.o = &overlapped;
     385  tcr->pending_io_info = &pending;
    369386  overlapped.hEvent = hevent;
    370387  ResetEvent(hevent);
    371388  if (WriteFile(hfile, buf, count, &nwritten, &overlapped)) {
     389    tcr->pending_io_info = NULL;
    372390    return nwritten;
    373391  }
    374392 
     393  err = GetLastError();
     394  if (err != ERROR_IO_PENDING) {
     395    _dosmaperr(err);
     396    tcr->pending_io_info = NULL;
     397    return -1;
     398  }
     399  err = 0;
     400  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
     401  tcr->pending_io_info = NULL;
     402  if (wait_result == WAIT_OBJECT_0) {
     403    err = overlapped.Internal;
     404    if (err) {
     405      _dosmaperr(err);
     406      return -1;
     407    }
     408    return overlapped.InternalHigh;
     409  }
     410  if (wait_result == WAIT_IO_COMPLETION) {
     411    CancelIo(hfile);
     412    errno = EINTR;
     413    return -1;
     414  }
    375415  err = GetLastError();
    376416  _dosmaperr(err);
  • branches/working-0711/ccl/lisp-kernel/x86-asmutils32.s

    r11412 r12198  
    174174_endfn
    175175        __endif
     176
     177        __ifdef([DARWIN])
     178_exportfn(C(darwin_sigreturn))
     179/* Need to set the sigreturn 'infostyle' argument, which is mostly
     180   undocumented.  On x8632 Darwin, sigtramp() sets it to 0x1e, and
     181   since we're trying to do what sigtramp() would do if we'd returned
     182   to it ... */
     183        __(movl $0x1e,8(%esp))
     184        __(movl $0xb8,%eax)     /* SYS_sigreturn */
     185        __(int $0x80)
     186        __(ret)                 /* shouldn't return */
     187
     188_endfn
     189        __endif       
    176190               
    177191_exportfn(C(get_vector_registers))
     
    186200_exportfn(C(restore_windows_context))
    187201Xrestore_windows_context_start:
     202        __(movl 4(%esp),%ecx)   /* context */
    188203        __(movl 12(%esp),%edx)  /* old valence */
    189204        __(movl 8(%esp),%eax)   /* tcr */
    190205        __(movw tcr.ldt_selector(%eax), %rcontext_reg)
    191         __(movl 4(%esp),%ecx)   /* context */
    192206        __(movl %edx,rcontext(tcr.valence))
    193207        __(movl $0,rcontext(tcr.pending_exception_context))
     
    211225        __(movl win32_context.Eax(%ecx),%eax)
    212226        __(movl win32_context.Esp(%ecx),%esp)
    213         __(pushl win32_context.Eip(%ecx))
    214 Xrestore_windows_context_load_rcx:               
     227        __(pushl win32_context.EFlags(%ecx))
     228        __(pushl %cs)
     229        __(pushl win32_context.Eip(%ecx))       
     230        /* This must be the last thing before the iret, e.g., if we're
     231        interrupted before the iret, the context we're returning to here
     232        is still in %ecx.  If we're interrupted -at- the iret, then
     233        everything but that which the iret will restore has been restored. */
    215234        __(movl win32_context.Ecx(%ecx),%ecx)
    216235Xrestore_windows_context_iret:           
    217         __(ret)
     236        __(iret)
    218237Xrestore_windows_context_end:             
    219238        __(nop)
     
    235254        .globl C(restore_windows_context_start)
    236255        .globl C(restore_windows_context_end)
    237         .globl C(restore_windows_context_load_rcx)
    238256        .globl C(restore_windows_context_iret)
    239257C(restore_windows_context_start):  .long Xrestore_windows_context_start
    240258C(restore_windows_context_end): .long Xrestore_windows_context_end
    241 C(restore_windows_context_load_rcx):  .long Xrestore_windows_context_load_rcx
    242259C(restore_windows_context_iret): .long Xrestore_windows_context_iret
    243260        .text
  • branches/working-0711/ccl/lisp-kernel/x86-asmutils64.s

    r11267 r12198  
    167167        __(movl $417,%eax)      /* SYS_sigreturn */
    168168        __(syscall)                             
     169       
    169170_exportfn(C(get_vector_registers))
    170171_endfn
     172
     173        __ifdef([DARWIN])
     174_exportfn(C(darwin_sigreturn))
     175        .globl C(sigreturn)
     176/* Need to set the sigreturn 'infostyle' argument, which is mostly
     177   undocumented.  On x8664 Darwin, sigtramp() sets it to 0x1e, and
     178   since we're trying to do what sigtramp() would do if we'd returned
     179   to it ... */
     180        __(movl $0x1e,%esi)
     181        __(movl $0x20000b8,%eax)
     182        __(syscall)
     183        __(ret)
     184_endfn
     185        __endif
    171186
    172187_exportfn(C(put_vector_registers))
     
    253268        __(movq win64_context.R14(%rcx),%r14)
    254269        __(movq win64_context.R15(%rcx),%r15)
    255 Xrestore_windows_context_load_rcx:               
     270        /* This must be the last thing before the iret, e.g., if we're
     271        interrupted before the iret, the context we're returning to here
     272        is still in %rcx.  If we're interrupted -at- the iret, then
     273        everything but that which the iret will restore has been restored. */
    256274        __(movq win64_context.Rcx(%rcx),%rcx)
    257275Xrestore_windows_context_iret:           
     
    272290        .globl C(restore_windows_context_start)
    273291        .globl C(restore_windows_context_end)
    274         .globl C(restore_windows_context_load_rcx)
    275292        .globl C(restore_windows_context_iret)
    276293C(restore_windows_context_start):  .quad Xrestore_windows_context_start
    277294C(restore_windows_context_end): .quad Xrestore_windows_context_end
    278 C(restore_windows_context_load_rcx):  .quad Xrestore_windows_context_load_rcx
    279295C(restore_windows_context_iret): .quad Xrestore_windows_context_iret
    280296        .text
  • branches/working-0711/ccl/lisp-kernel/x86-constants.s

    r10389 r12198  
    8989         _node(lexpr_return)            /* magic &lexpr return code.   */
    9090         _node(all_areas)               /* doubly-linked list of all memory areas   */
    91          _node(bad_funcall)             /* pseudo-funcall target for cmove  */
     91         _node(kernel_path)             /* real executable name */
    9292         _node(objc2_begin_catch)       /* objc_begin_catch   */
    9393         _node(BAD_current_vs)          /* current value-stack area   */
  • branches/working-0711/ccl/lisp-kernel/x86-constants32.h

    r11412 r12198  
    371371#define lfbits_noname_mask fixnum_bitmask(29)
    372372
    373 /*
    374   known values of an "extended" (gcable) macptr's flags word:
    375 */
    376 
    377 typedef enum {
    378   xmacptr_flag_none = 0,        /* Maybe already disposed by Lisp */
    379   xmacptr_flag_recursive_lock,  /* recursive-lock */
    380   xmacptr_flag_ptr,             /* malloc/free */
    381   xmacptr_flag_rwlock,          /* read/write lock */
    382   xmacptr_flag_semaphore        /* semaphore */
    383 } xmacptr_flag;
    384373
    385374/* Creole */
     
    495484#define misc_data_offset misc_header_offset + node_size
    496485
     486typedef struct {
     487  natural Eip;
     488  natural Cs;                   /* in low 16 bits */
     489  natural EFlags;
     490} ia32_iret_frame;
     491
    497492#define heap_segment_size 0x00010000
    498493#define log2_heap_segment_size 16
  • branches/working-0711/ccl/lisp-kernel/x86-constants64.h

    r11267 r12198  
    444444*/
    445445
    446 typedef enum {
    447   xmacptr_flag_none = 0,        /* Maybe already disposed by Lisp */
    448   xmacptr_flag_recursive_lock,  /* recursive-lock */
    449   xmacptr_flag_ptr,             /* malloc/free */
    450   xmacptr_flag_rwlock,          /* read/write lock */
    451   xmacptr_flag_semaphore        /* semaphore */
    452 } xmacptr_flag;
    453446
    454447/* Creole */
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.c

    r11947 r12198  
    158158natural gc_deferred = 0, full_gc_deferred = 0;
    159159
     160signed_natural
     161flash_freeze(TCR *tcr, signed_natural param)
     162{
     163  return 0;
     164}
     165
     166
    160167Boolean
    161168handle_gc_trap(ExceptionInformation *xp, TCR *tcr)
     
    212219    }
    213220    xpGPR(xp, Iimm0) = lisp_heap_gc_threshold;
     221    break;
     222
     223  case GC_TRAP_FUNCTION_FLASH_FREEZE: /* Like freeze below, but no GC */
     224    untenure_from_area(tenured_area);
     225    gc_like_from_xp(xp,flash_freeze,0);
     226    a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size);
     227    tenured_area->static_dnodes = area_dnode(a->active, a->low);
     228    if (egc_was_enabled) {
     229      tenure_to_area(tenured_area);
     230    }
     231    xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift;
    214232    break;
    215233
     
    249267      if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) {
    250268        OSErr err;
    251         extern OSErr save_application(unsigned);
     269        extern OSErr save_application(unsigned, Boolean);
    252270        area *vsarea = tcr->vs_area;
    253271
     
    256274#endif
    257275        nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1);
    258         err = save_application(arg);
     276        err = save_application(arg, egc_was_enabled);
    259277        if (err == noErr) {
    260278          _exit(0);
     
    418436
    419437#ifdef X8664
    420   if (fulltag_of(f) == fulltag_function) {
    421 #else
    422   if (fulltag_of(f) == fulltag_misc &&
    423       header_subtag(header_of(f)) == subtag_function) {
    424 #endif
    425     nominal_function = f;
    426   } else {
    427     if (tra_f) {
    428       nominal_function = tra_f;
    429     }
    430   }
     438  if (fulltag_of(f) == fulltag_function)
     439#else
     440    if (fulltag_of(f) == fulltag_misc &&
     441        header_subtag(header_of(f)) == subtag_function)
     442#endif
     443      {
     444        nominal_function = f;
     445      } else {
     446      if (tra_f) {
     447        nominal_function = tra_f;
     448      }
     449    }
    431450 
    432451  f = xpGPR(xp,Ifn);
     
    475494#endif
    476495
     496void
     497lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed )
     498{
     499  LispObj xcf = create_exception_callback_frame(xp, tcr),
     500    cmain = nrs_CMAIN.vcell;
     501  int skip;
     502   
     503  tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
     504  xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
     505
     506  skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
     507  xpPC(xp) += skip;
     508}
     509
     510/*
     511  Allocate a large list, where "large" means "large enough to
     512  possibly trigger the EGC several times if this was done
     513  by individually allocating each CONS."  The number of
     514  ocnses in question is in arg_z; on successful return,
     515  the list will be in arg_z
     516*/
     517
     518Boolean
     519allocate_list(ExceptionInformation *xp, TCR *tcr)
     520{
     521  natural
     522    nconses = (unbox_fixnum(xpGPR(xp,Iarg_z))),
     523    bytes_needed = (nconses << dnode_shift);
     524  LispObj
     525    prev = lisp_nil,
     526    current,
     527    initial = xpGPR(xp,Iarg_y);
     528
     529  if (nconses == 0) {
     530    /* Silly case */
     531    xpGPR(xp,Iarg_z) = lisp_nil;
     532    xpGPR(xp,Iallocptr) = lisp_nil;
     533    return true;
     534  }
     535  update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr);
     536  if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) {
     537    tcr->save_allocptr -= fulltag_cons;
     538    for (current = xpGPR(xp,Iallocptr);
     539         nconses;
     540         prev = current, current+= dnode_size, nconses--) {
     541      deref(current,0) = prev;
     542      deref(current,1) = initial;
     543    }
     544    xpGPR(xp,Iarg_z) = prev;
     545  } else {
     546    lisp_allocation_failure(xp,tcr,bytes_needed);
     547  }
     548  return true;
     549}
     550
    477551Boolean
    478552handle_alloc_trap(ExceptionInformation *xp, TCR *tcr)
     
    500574  }
    501575 
    502   {
    503     LispObj xcf = create_exception_callback_frame(xp, tcr),
    504       cmain = nrs_CMAIN.vcell;
    505     int skip;
    506    
    507     tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR;
    508     xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
    509 
    510     skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0);
    511     xpPC(xp) += skip;
    512   }
     576  lisp_allocation_failure(xp,tcr,bytes_needed);
    513577
    514578  return true;
     
    525589#ifdef X8632
    526590  natural saved_node_regs_mask = tcr->node_regs_mask;
     591  natural saved_unboxed0 = tcr->unboxed0;
     592  natural saved_unboxed1 = tcr->unboxed1;
    527593  LispObj *vsp = (LispObj *)xpGPR(xp, Isp);
    528594#endif
     
    565631
    566632  tcr->node_regs_mask = saved_node_regs_mask;
     633  tcr->unboxed0 = saved_unboxed0;
     634  tcr->unboxed1 = saved_unboxed1;
    567635#endif
    568636  set_mxcsr(old_mxcsr);
     
    10911159        return true;
    10921160
     1161      case XUUO_ALLOCATE_LIST:
     1162        allocate_list(context,tcr);
     1163        xpPC(context)+=3;
     1164        return true;
     1165
    10931166      default:
    10941167        return false;
     
    11661239  LOCK(lisp_global(EXCEPTION_LOCK), tcr);
    11671240#if 0
    1168   fprintf(stderr, "0x" LISP " has exception lock\n", tcr);
     1241  fprintf(dbgout, "0x" LISP " has exception lock\n", tcr);
    11691242#endif
    11701243  xf->curr = context;
     
    11891262  UNLOCK(lisp_global(EXCEPTION_LOCK),tcr);
    11901263#if 0
    1191   fprintf(stderr, "0x" LISP " released exception lock\n", tcr);
     1264  fprintf(dbgout, "0x" LISP " released exception lock\n", tcr);
    11921265#endif
    11931266}
     
    12831356#endif
    12841357
    1285 #ifdef DARWIN
    1286 void
    1287 pseudo_signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
    1288 {
    1289   sigset_t mask;
    1290 
    1291   sigfillset(&mask);
    1292 
    1293   pthread_sigmask(SIG_SETMASK,&mask,&(context->uc_sigmask));
    1294   signal_handler(signum, info, context, tcr, old_valence);
    1295 }
    1296 #endif
    12971358
    12981359
     
    14501511#endif
    14511512
    1452 #ifdef DARWIN
    1453 void
    1454 bogus_signal_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
    1455 {
    1456   if (signum == SIGSYS) {
    1457     return;                     /* Leopard lossage */
    1458   }
    1459 }
    1460 #endif
    14611513
    14621514#ifndef WINDOWS
     
    17711823}
    17721824
     1825static
     1826DWORD mxcsr_bit_to_fpe_code[] = {
     1827  EXCEPTION_FLT_INVALID_OPERATION, /* ie */
     1828  0,                            /* de */
     1829  EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */
     1830  EXCEPTION_FLT_OVERFLOW,       /* oe */
     1831  EXCEPTION_FLT_UNDERFLOW,      /* ue */
     1832  EXCEPTION_FLT_INEXACT_RESULT  /* pe */
     1833};
     1834
     1835#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
     1836#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4
     1837#endif
     1838
     1839#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
     1840#define  STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5
     1841#endif
     1842
    17731843int
    1774 map_windows_exception_code_to_posix_signal(DWORD code)
     1844map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context)
    17751845{
    17761846  switch (code) {
     1847#ifdef WIN_32
     1848  case STATUS_FLOAT_MULTIPLE_FAULTS:
     1849  case STATUS_FLOAT_MULTIPLE_TRAPS:
     1850    {
     1851      int xbit, maskbit;
     1852      DWORD mxcsr = *(xpMXCSRptr(context));
     1853
     1854      for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) {
     1855        if ((mxcsr & (1 << xbit)) &&
     1856            !(mxcsr & (1 << maskbit))) {
     1857          info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit];
     1858          break;
     1859        }
     1860      }
     1861    }
     1862    return SIGFPE;
     1863#endif
     1864     
    17771865  case EXCEPTION_ACCESS_VIOLATION:
    17781866    return SIGSEGV;
     
    18101898  wait_for_exception_lock_in_handler(tcr, context, &xframes);
    18111899
    1812   signal_number = map_windows_exception_code_to_posix_signal(code);
     1900  signal_number = map_windows_exception_code_to_posix_signal(code, info, context);
    18131901 
    18141902  if (!handle_exception(signal_number, info, context, tcr, old_valence)) {
     
    19372025  install_signal_handler(SIGSEGV,handler);
    19382026  install_signal_handler(SIGFPE, handler);
    1939 #else
    1940   install_signal_handler(SIGTRAP,bogus_signal_handler);
    1941   install_signal_handler(SIGILL, bogus_signal_handler);
    1942  
    1943   install_signal_handler(SIGBUS, bogus_signal_handler);
    1944   install_signal_handler(SIGSEGV,bogus_signal_handler);
    1945   install_signal_handler(SIGFPE, bogus_signal_handler);
    1946   /*  9.0.0d8 generates spurious SIGSYS from mach_msg_trap */
    1947   install_signal_handler(SIGSYS, bogus_signal_handler);
    19482027#endif
    19492028 
     
    19682047#endif
    19692048  TCR *tcr = get_interrupt_tcr(false);
    1970   area *vs = tcr->vs_area;
    1971   BytePtr current_sp = (BytePtr) current_stack_pointer();
    1972 
    1973   if ((current_sp >= vs->low) &&
    1974       (current_sp < vs->high)) {
    1975     handle_signal_on_foreign_stack(tcr,
    1976                                    suspend_resume_handler,
    1977                                    signum,
    1978                                    info,
    1979                                    context,
    1980                                    (LispObj)__builtin_return_address(0)
     2049  if (tcr != NULL) {
     2050    area *vs = tcr->vs_area;
     2051    BytePtr current_sp = (BytePtr) current_stack_pointer();
     2052   
     2053    if ((current_sp >= vs->low) &&
     2054        (current_sp < vs->high)) {
     2055      return
     2056        handle_signal_on_foreign_stack(tcr,
     2057                                       suspend_resume_handler,
     2058                                       signum,
     2059                                       info,
     2060                                       context,
     2061                                       (LispObj)__builtin_return_address(0)
    19812062#ifdef DARWIN_GS_HACK
    1982                                    ,gs_was_tcr
    1983 #endif
    1984                                    );
    1985   } else {
    1986     /* If we're not on the value stack, we pretty much have to be on
    1987        the C stack.  Just run the handler. */
     2063                                       ,gs_was_tcr
     2064#endif
     2065                                       );
     2066    } else {
     2067      /* If we're not on the value stack, we pretty much have to be on
     2068         the C stack.  Just run the handler. */
    19882069#ifdef DARWIN_GS_HACK
    1989     if (gs_was_tcr) {
    1990       set_gs_address(tcr);
    1991     }
    1992 #endif
    1993     suspend_resume_handler(signum, info, context);
    1994   }
     2070      if (gs_was_tcr) {
     2071        set_gs_address(tcr);
     2072      }
     2073#endif
     2074    }
     2075  }
     2076  suspend_resume_handler(signum, info, context);
    19952077}
    19962078
     
    22212303extern opcode egc_write_barrier_start, egc_write_barrier_end,
    22222304  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
    2223   egc_store_node_conditional_success_end,
     2305  egc_set_hash_key_conditional_retry,
     2306  egc_store_node_conditional_success_end, egc_store_node_conditional_retry,
    22242307  egc_store_node_conditional_success_test,egc_store_node_conditional,
    22252308  egc_set_hash_key, egc_gvset, egc_rplacd;
     
    22522335;
    22532336opcode branch_around_alloc_trap_instruction[] =
    2254   {0x7f,0x02};
     2337  {0x77,0x02};
    22552338opcode alloc_trap_instruction[] =
    22562339  {0xcd,0xc5};
     
    22712354  switch(program_counter[0]) {
    22722355  case 0xcd: return ID_alloc_trap_instruction;
    2273   case 0x7f: return ID_branch_around_alloc_trap_instruction;
     2356  /* 0x7f is jg, which we used to use here instead of ja */
     2357  case 0x7f:
     2358  case 0x77: return ID_branch_around_alloc_trap_instruction;
    22742359  case 0x48: return ID_set_allocptr_header_instruction;
    22752360#ifdef WINDOWS
     
    22972382#endif
    22982383#ifdef X8632
     2384/* The lisp assembler might use both a modrm byte and a sib byte to
     2385   encode a memory operand that contains a displacement but no
     2386   base or index.  Using the sib byte is necessary for 64-bit code,
     2387   since the sib-less form is used to indicate %rip-relative addressing
     2388   on x8664.  On x8632, it's not necessary, slightly suboptimal, and
     2389   doesn't match what we expect; until that's fixed, we may need to
     2390   account for this extra byte when adjusting the PC */
     2391#define LISP_ASSEMBLER_EXTRA_SIB_BYTE
     2392#ifdef WIN32_ES_HACK
     2393/* Win32 keeps the TCR in %es */
     2394#define TCR_SEG_PREFIX 0x26     /* %es: */
     2395#else
     2396/* Other platfroms use %fs */
     2397#define TCR_SEG_PREFIX 0x64     /* %fs: */
     2398#endif
    22992399opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] =
    2300   {0x64,0x8b,0x0d,0x84,0x00,0x00,0x00};
     2400  {TCR_SEG_PREFIX,0x8b,0x0d,0x84,0x00,0x00,0x00};  /* may have extra SIB byte */
    23012401opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] =
    2302   {0x64,0x3b,0x0d,0x88,0x00,0x00,0x00};
     2402  {TCR_SEG_PREFIX,0x3b,0x0d,0x88,0x00,0x00,0x00};  /* may have extra SIB byte */
    23032403opcode branch_around_alloc_trap_instruction[] =
    2304   {0x7f,0x02};
     2404  {0x77,0x02};                  /* no SIB byte issue */
    23052405opcode alloc_trap_instruction[] =
    2306   {0xcd,0xc5};
     2406  {0xcd,0xc5};                  /* no SIB byte issue */
    23072407opcode clear_tcr_save_allocptr_tag_instruction[] =
    2308   {0x64,0x80,0x25,0x84,0x00,0x00,0x00,0xf8};
     2408  {TCR_SEG_PREFIX,0x80,0x25,0x84,0x00,0x00,0x00,0xf8}; /* maybe SIB byte */
    23092409opcode set_allocptr_header_instruction[] =
    2310   {0x0f,0x7e,0x41,0xfa};
     2410  {0x0f,0x7e,0x41,0xfa};        /* no SIB byte issue */
    23112411
    23122412alloc_instruction_id
     
    23152415  switch(program_counter[0]) {
    23162416  case 0xcd: return ID_alloc_trap_instruction;
    2317   case 0x7f: return ID_branch_around_alloc_trap_instruction;
     2417  /* 0x7f is jg, which we used to use here instead of ja */
     2418  case 0x7f:
     2419  case 0x77: return ID_branch_around_alloc_trap_instruction;
    23182420  case 0x0f: return ID_set_allocptr_header_instruction;
    2319   case 0x64:
     2421  case TCR_SEG_PREFIX:
    23202422    switch(program_counter[1]) {
    23212423    case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction;
     
    23402442      sizeof(cons) - fulltag_cons :
    23412443#ifdef X8664
    2342       xpGPR(xp,Iimm1);
    2343 #else
    2344       xpGPR(xp,Iimm0);
    2345 #endif
     2444      xpGPR(xp,Iimm1)
     2445#else
     2446      xpGPR(xp,Iimm0)
     2447#endif
     2448      ;
    23462449    LispObj new_vector;
    23472450
     
    23532456    switch(state) {
    23542457    case ID_set_allocptr_header_instruction:
    2355       /* We were consing a vector and we won.  Set the header of the new vector
    2356          (in the allocptr register) to the header in %rax and skip over this
    2357          instruction, then fall into the next case. */
     2458      /* We were consing a vector and we won.  Set the header of the
     2459         new vector (in the allocptr register) to the header in %rax
     2460         (%mm0 on ia32) and skip over this instruction, then fall into
     2461         the next case. */
    23582462      new_vector = xpGPR(xp,Iallocptr);
    2359       deref(new_vector,0) = xpGPR(xp,Iimm0);
    2360 
     2463      deref(new_vector,0) =
     2464#ifdef X8664
     2465        xpGPR(xp,Iimm0)
     2466#else
     2467        xpMMXreg(xp,Imm0)
     2468#endif
     2469        ;
     2470     
    23612471      xpPC(xp) += sizeof(set_allocptr_header_instruction);
     2472
    23622473      /* Fall thru */
    23632474    case ID_clear_tcr_save_allocptr_tag_instruction:
    23642475      tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
     2476#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
     2477      if (((pc)(xpPC(xp)))[2] == 0x24) {
     2478        xpPC(xp) += 1;
     2479      }
     2480#endif
    23652481      xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
     2482
    23662483      break;
    23672484    case ID_alloc_trap_instruction:
     
    23792496        xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
    23802497        tcr->save_allocptr += disp;
     2498#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
     2499        /* This assumes that TCR_SEG_PREFIX can't appear
     2500           anywhere but at the beginning of one of these
     2501           magic allocation-sequence instructions. */
     2502        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
     2503                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction));
     2504        if (*((pc)(xpPC(xp))) == TCR_SEG_PREFIX) {
     2505          xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
     2506        } else {
     2507          xpPC(xp) -= (sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction) + 2);
     2508        }
     2509       
     2510#else
    23812511        xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+
    23822512                     sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
    23832513                     sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
     2514#endif
    23842515      }
    23852516      break;
    23862517    case ID_branch_around_alloc_trap_instruction:
    2387       /* If we'd take the branch - which is a "jg" - around the alloc trap,
     2518      /* If we'd take the branch - which is a "ja" - around the alloc trap,
    23882519         we might as well finish the allocation.  Otherwise, back out of the
    23892520         attempt. */
     
    23922523       
    23932524        if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) &&
    2394             ((flags & (1 << X86_SIGN_FLAG_BIT)) ==
    2395              (flags & (1 << X86_CARRY_FLAG_BIT)))) {
    2396           /* The branch (jg) would have been taken.  Emulate taking it. */
     2525            (!(flags & (1 << X86_CARRY_FLAG_BIT)))) {
     2526          /* The branch (ja) would have been taken.  Emulate taking it. */
    23972527          xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+
    23982528                       sizeof(alloc_trap_instruction));
     
    24042534          }
    24052535          tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask);
     2536#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
     2537          if (((pc)xpPC(xp))[2] == 0x24) {
     2538            xpPC(xp) += 1;
     2539          }
     2540#endif
    24062541          xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction);
    24072542        } else {
     
    24092544          xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) +
    24102545                       sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction));
     2546#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
     2547          if (*((pc)(xpPC(xp))) != TCR_SEG_PREFIX) {
     2548            /* skipped two instructions with extra SIB byte */
     2549            xpPC(xp) -= 2;
     2550          }
     2551#endif
    24112552          xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
    24122553          if (interrupt_displacement) {
     
    24222563      xpGPR(xp,Iallocptr) = VOID_ALLOCPTR;
    24232564      xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction);
     2565#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE
     2566      if (*((pc)xpPC(xp)) != TCR_SEG_PREFIX) {
     2567        xpPC(xp) -= 1;
     2568      }
     2569#endif
    24242570      /* Fall through */
    24252571    case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction:
     
    24432589
    24442590    if (program_counter >= &egc_set_hash_key_conditional) {
     2591      if (program_counter <= &egc_set_hash_key_conditional_retry) {
     2592        return;
     2593      }
    24452594      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
    24462595          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
    24472596           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
    24482597        /* Back up the PC, try again */
    2449         xpPC(xp) = (LispObj) &egc_set_hash_key_conditional;
     2598        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry;
    24502599        return;
    24512600      }
     
    24632612      xpGPR(xp,Iarg_z) = t_value;
    24642613    } else if (program_counter >= &egc_store_node_conditional) {
     2614      if (program_counter <= &egc_store_node_conditional_retry) {
     2615        return;
     2616      }
    24652617      if ((program_counter < &egc_store_node_conditional_success_test) ||
    24662618          ((program_counter == &egc_store_node_conditional_success_test) &&
    24672619           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
    24682620        /* Back up the PC, try again */
    2469         xpPC(xp) = (LispObj) &egc_store_node_conditional;
     2621        xpPC(xp) = (LispObj) &egc_store_node_conditional_retry;
    24702622        return;
    24712623      }
     
    25772729
    25782730
    2579 int
     2731signed_natural
    25802732gc_like_from_xp(ExceptionInformation *xp,
    2581                 int(*fun)(TCR *, signed_natural),
     2733                signed_natural(*fun)(TCR *, signed_natural),
    25822734                signed_natural param)
    25832735{
     
    26432795}
    26442796
    2645 int
     2797signed_natural
    26462798purify_from_xp(ExceptionInformation *xp, signed_natural param)
    26472799{
     
    26492801}
    26502802
    2651 int
     2803signed_natural
    26522804impurify_from_xp(ExceptionInformation *xp, signed_natural param)
    26532805{
     
    26572809/* Returns #bytes freed by invoking GC */
    26582810
    2659 int
     2811signed_natural
    26602812gc_from_tcr(TCR *tcr, signed_natural param)
    26612813{
     
    26652817
    26662818#if 0
    2667   fprintf(stderr, "Start GC  in 0x" LISP "\n", tcr);
     2819  fprintf(dbgout, "Start GC  in 0x" LISP "\n", tcr);
    26682820#endif
    26692821  a = active_dynamic_area;
     
    26742826  newend = a->high;
    26752827#if 0
    2676   fprintf(stderr, "End GC  in 0x" LISP "\n", tcr);
     2828  fprintf(dbgout, "End GC  in 0x" LISP "\n", tcr);
    26772829#endif
    26782830  return ((oldfree-newfree)+(newend-oldend));
    26792831}
    26802832
    2681 int
     2833signed_natural
    26822834gc_from_xp(ExceptionInformation *xp, signed_natural param)
    26832835{
    2684   int status = gc_like_from_xp(xp, gc_from_tcr, param);
     2836  signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param);
    26852837
    26862838  freeGCptrs();
     
    28472999
    28483000#ifdef DEBUG_MACH_EXCEPTIONS
    2849   fprintf(stderr, "doing pseudo_sigreturn for 0x%x\n",tcr);
     3001  fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr);
    28503002#endif
    28513003  xp = tcr->pending_exception_context;
     
    28593011  }
    28603012#ifdef DEBUG_MACH_EXCEPTIONS
    2861   fprintf(stderr, "did pseudo_sigreturn for 0x%x\n",tcr);
     3013  fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr);
    28623014#endif
    28633015  return KERN_SUCCESS;
     
    29783130
    29793131#ifdef DEBUG_MACH_EXCEPTIONS
    2980   fprintf(stderr,"Setting up exception handling for 0x%x\n", tcr);
     3132  fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr);
    29813133#endif
    29823134  pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr,  ts);
     
    30533205#endif
    30543206#ifdef DEBUG_MACH_EXCEPTIONS
    3055   fprintf(stderr,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
     3207  fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context);
    30563208#endif
    30573209  return 0;
     
    30943246#endif
    30953247
    3096 #ifdef DARWIN_USE_PSEUDO_SIGRETURN
     3248
    30973249#define DARWIN_EXCEPTION_HANDLER signal_handler
    3098 #else
    3099 #define DARWIN_EXCEPTION_HANDLER pseudo_signal_handler
    3100 #endif
    31013250
    31023251
     
    31213270
    31223271
     3272
    31233273#ifdef DEBUG_MACH_EXCEPTIONS
    3124   fprintf(stderr, "obtaining Mach exception lock in exception thread\n");
     3274  fprintf(dbgout, "obtaining Mach exception lock in exception thread\n");
    31253275#endif
    31263276
     
    31513301      kret = do_pseudo_sigreturn(thread, tcr);
    31523302#if 0
    3153       fprintf(stderr, "Exception return in 0x%x\n",tcr);
     3303      fprintf(dbgout, "Exception return in 0x%x\n",tcr);
    31543304#endif
    31553305    } else if (tcr->flags & (1<<TCR_FLAG_BIT_PROPAGATE_EXCEPTION)) {
     
    31933343                                  &ts);
    31943344#if 0
    3195         fprintf(stderr, "Setup pseudosignal handling in 0x%x\n",tcr);
     3345        fprintf(dbgout, "Setup pseudosignal handling in 0x%x\n",tcr);
    31963346#endif
    31973347       
     
    32333383  kern_return_t kret;
    32343384
    3235   fprintf(stderr, "terminating Mach exception thread, 'cause exit can't\n");
     3385  fprintf(dbgout, "terminating Mach exception thread, 'cause exit can't\n");
    32363386  kret = thread_terminate(mach_exception_thread);
    32373387  if (kret != KERN_SUCCESS) {
    3238     fprintf(stderr, "Couldn't terminate exception thread, kret = %d\n",kret);
     3388    fprintf(dbgout, "Couldn't terminate exception thread, kret = %d\n",kret);
    32393389  }
    32403390}
     
    33943544  if ((kret = setup_mach_exception_handling(tcr))
    33953545      != KERN_SUCCESS) {
    3396     fprintf(stderr, "Couldn't setup exception handler - error = %d\n", kret);
     3546    fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret);
    33973547    terminate_lisp();
    33983548  }
     
    34373587        aborted = true;
    34383588      } else {
    3439         fprintf(stderr, "abort failed on thread = 0x%x\n",mach_thread);
     3589        fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread);
    34403590        thread_resume(mach_thread);
    34413591      }
     
    34953645  xp = tcr->suspend_context;
    34963646#ifdef DEBUG_MACH_EXCEPTIONS
    3497   fprintf(stderr, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
     3647  fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n",
    34983648          tcr, tcr->pending_exception_context);
    34993649#endif
     
    35013651  restore_mach_thread_state(mach_thread, xp);
    35023652#ifdef DEBUG_MACH_EXCEPTIONS
    3503   fprintf(stderr, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
     3653  fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n",
    35043654          tcr, tcr->pending_exception_context);
    35053655#endif
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.h

    r11947 r12198  
    3232#define DARWIN_USE_PSEUDO_SIGRETURN 1
    3333#include <sys/syscall.h>
    34 #define DarwinSigReturn(context) syscall(0x2000000|SYS_sigreturn,context,0x1e)
     34#define DarwinSigReturn(context) do {\
     35    darwin_sigreturn(context);\
     36    Bug(context,"sigreturn returned");\
     37  } while (0)
     38
    3539#define xpGPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__ss)))
    3640#define xpGPR(x,gprno) (xpGPRvector(x)[gprno])
     
    9094#define xpPC(x) xpGPR(x,Iip)
    9195#define eflags_register(xp) xp->EFlags
     96#define xpMXCSRptr(x) (DWORD *)(&(x->MxCsr))
    9297#else
    9398#define xpGPRvector(x) ((DWORD *)(&(x)->Edi))
     
    97102#define xpFPRvector(x) ((natural *)(&(x->ExtendedRegisters[10*16])))
    98103#define xpMMXreg(x,n)  (*((u64_t *)(&(x->FloatSave.RegisterArea[10*(n)]))))
     104#define xpMXCSRptr(x) (DWORD *)(&(x->ExtendedRegisters[24]))
    99105#endif
    100106#endif
     
    145151#define XUUO_RESUME_ALL 8
    146152#define XUUO_KILL 9
     153#define XUUO_ALLOCATE_LIST 10
    147154
    148155void
  • branches/working-0711/ccl/lisp-kernel/x86-gc.c

    r11267 r12198  
    375375  }
    376376
     377  dnode = gc_area_dnode(n);
     378  if (dnode >= GCndnodes_in_area) {
     379    return;
     380  }
     381
    377382#ifdef X8632
    378383  if (tag_n == fulltag_tra) {
     
    380385      n = *(LispObj *)(n + 1);
    381386      tag_n = fulltag_misc;
     387      dnode = gc_area_dnode(n);
    382388    } else
    383389      return;
     
    391397      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
    392398      tag_n = fulltag_function;
     399      dnode = gc_area_dnode(n);
    393400    }
    394401    else {
     
    398405#endif
    399406
    400 
    401   dnode = gc_area_dnode(n);
    402   if (dnode >= GCndnodes_in_area) {
    403     return;
    404   }
    405407  set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask);
    406408  if (bits & mask) {
     
    594596  }
    595597
     598  dnode = gc_area_dnode(n);
     599  if (dnode >= GCndnodes_in_area) {
     600    return;
     601  }
     602
    596603#ifdef X8632
    597604  if (tag_n == fulltag_tra) {
     
    599606      n = *(LispObj *)(n + 1);
    600607      tag_n = fulltag_misc;
     608      dnode = gc_area_dnode(n);
    601609    } else {
    602610      return;
     
    611619      n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp;
    612620      tag_n = fulltag_function;
     621      dnode = gc_area_dnode(n);
    613622    } else {
    614623      return;
     
    617626#endif
    618627
    619   dnode = gc_area_dnode(n);
    620   if (dnode >= GCndnodes_in_area) {
    621     return;
    622   }
    623628  set_bits_vars(markbits,dnode,bitsp,bits,mask);
    624629  if (bits & mask) {
     
    11521157        x1 = start[1];
    11531158        tag = fulltag_of(x1);
    1154       if (is_node_fulltag(tag)) {       
     1159        if (is_node_fulltag(tag)) {       
    11551160          node_dnode = gc_area_dnode(x1);
    11561161          if (node_dnode < GCndnodes_in_area) {
     
    13641369
    13651370#if 0
    1366   fprintf(stderr, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end);
     1371  fprintf(dbgout, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end);
    13671372#endif
    13681373  mark_headerless_area_range(start, end);
     
    18541859
    18551860  i = ((unsigned short *)node)[2];
    1856   offset = node[--i];
    1857   while (offset) {
    1858     *(LispObj *)(p + offset) = fn;
     1861  if (i) {
    18591862    offset = node[--i];
     1863    while (offset) {
     1864      *(LispObj *)(p + offset) = fn;
     1865      offset = node[--i];
     1866    }
    18601867  }   
    18611868}
     
    19301937#endif
    19311938            *dest++ = node;
    1932             elements -= skip;
    1933             while(skip--) {
    1934               *dest++ = *src++;
    1935             }
     1939            if (skip) {
     1940              elements -= skip;
     1941              while(skip--) {
     1942                *dest++ = *src++;
     1943              }
    19361944#ifdef X8632
    1937             update_self_references(f);
    1938 #endif
     1945              update_self_references(f);
     1946#endif
     1947            }
    19391948            while(elements--) {
    19401949              *dest++ = node_forwarding_address(*src++);
     
    24112420
    24122421
    2413 int
     2422signed_natural
    24142423purify(TCR *tcr, signed_natural param)
    24152424{
     
    26952704}
    26962705
    2697 int
     2706signed_natural
    26982707impurify(TCR *tcr, signed_natural param)
    26992708{
  • branches/working-0711/ccl/lisp-kernel/x86-macros.s

    r10944 r12198  
    274274        __(movl rcontext(tcr.save_allocptr),%allocptr)
    275275        __(rcmpl(%allocptr,rcontext(tcr.save_allocbase)))
    276         __(jg macro_label(no_trap))
     276        __(ja macro_label(no_trap))
    277277        uuo_alloc()
    278278macro_label(no_trap):
     
    294294        __(movq rcontext(tcr.save_allocptr),%allocptr)
    295295        __(rcmpq(%allocptr,rcontext(tcr.save_allocbase)))
    296         __(jg macro_label(no_trap))
     296        __(ja macro_label(no_trap))
    297297        uuo_alloc()
    298298macro_label(no_trap):   
     
    327327        __(movl rcontext(tcr.save_allocptr),%allocptr)
    328328        __(cmpl rcontext(tcr.save_allocbase),%allocptr)
    329         __(jg macro_label(no_trap))
     329        __(ja macro_label(no_trap))
    330330        uuo_alloc()
    331331macro_label(no_trap):   
     
    342342        __(movq rcontext(tcr.save_allocptr),%allocptr)
    343343        __(rcmpq(%allocptr,rcontext(tcr.save_allocbase)))
    344         __(jg macro_label(no_trap))
     344        __(ja macro_label(no_trap))
    345345        uuo_alloc()
    346346macro_label(no_trap):   
     
    708708macro_label(done):
    709709])
     710
     711        __ifdef([WINDOWS])
     712define([windows_cstack_probe],[
     713        new_macro_labels()
     714        __(cmp [$]0x1000,$1)
     715        __(jb macro_label(done))
     716        __(mov rcontext(tcr.foreign_sp),$2)
     717        __(orl [$]0,-0x1000($2))
     718        __(cmp [$]0x2000,$1)
     719        __(jb macro_label(done))
     720        __(orl [$]0,-0x2000($2))
     721        __(cmp [$]0x3000,$1)
     722        __(jb macro_label(done))
     723        __(orl [$]0,-0x3000($2))
     724        __(cmp [$]0x4000,$1)
     725        __(jb macro_label(done))
     726        __(orl [$]0,-0x4000($2))
     727        __(cmp [$]0x5000,$1)
     728        __(jb macro_label(done))
     729        __(orl [$]0,-0x5000($2))
     730        __(cmp [$]0x6000,$1)
     731        __(jb macro_label(done))
     732        __(orl [$]0,-0x6000($2))
     733        __(cmp [$]0x7000,$1)
     734        __(jb macro_label(done))
     735        __(orl [$]0,-0x7000($2))
     736        __(cmp [$]0x8000,$1)
     737        __(jb macro_label(done))
     738        __(orl [$]0,-0x8000($2))
     739        __(cmp [$]0x9000,$1)
     740        __(jb macro_label(done))
     741        __(orl [$]0,-0x9000($2))
     742        __(cmp [$]0xa000,$1)
     743        __(jb macro_label(done))
     744        __(orl [$]0,-0xa000($2))
     745        __(cmp [$]0xb000,$1)
     746        __(jb macro_label(done))
     747        __(orl [$]0,-0xb000($2))
     748        __(cmp [$]0xc000,$1)
     749        __(jb macro_label(done))
     750        __(orl [$]0,-0xc000($2))
     751        __(cmp [$]0xd000,$1)
     752        __(jb macro_label(done))
     753        __(orl [$]0,-0xd000($2))
     754        __(cmp [$]0xe000,$1)
     755        __(jb macro_label(done))
     756        __(orl [$]0,-0xe000($2))
     757        __(cmp [$]0xf000,$1)
     758        __(jb macro_label(done))
     759        __(orl [$]0,-0xf000($2))
     760macro_label(done):     
     761])
     762
     763
     764        __endif               
    710765                       
  • branches/working-0711/ccl/lisp-kernel/x86-spentry32.s

    r11412 r12198  
    105105        .long local_label(misc_ref_invalid) /* 20 even_fixnum  */
    106106        .long local_label(misc_ref_invalid) /* 21 cons  */
    107         .long local_label(misc_ref_invalid) /* 22 catch_frame  */
     107        .long local_label(misc_ref_node) /* 22 catch_frame  */
    108108        .long local_label(misc_ref_invalid) /* 23 imm  */
    109109        .long local_label(misc_ref_invalid) /* 24 odd_fixnum  */
     
    122122        .long local_label(misc_ref_invalid) /* 30 even_fixnum  */
    123123        .long local_label(misc_ref_invalid) /* 31 cons  */
    124         .long local_label(misc_ref_invalid) /* 32 nodeheader  */
     124        .long local_label(misc_ref_node) /* 32 basic_stream  */
    125125        .long local_label(misc_ref_invalid) /* 33 imm  */
    126126        .long local_label(misc_ref_invalid) /* 34 odd_fixnum  */
     
    414414        __(ret)
    415415local_label(misc_ref_invalid):
     416        __(pop %temp1)  /* return addr */
    416417        __(push $reserved_frame_marker)
    417418        __(push $reserved_frame_marker)
    418419        __(push $XBADVEC)
     420        __(push %temp1)
    419421        __(set_nargs(3))
    420422        __(jmp _SPksignalerr)
     
    527529        .long local_label(misc_set_invalid) /* 20 even_fixnum  */
    528530        .long local_label(misc_set_invalid) /* 21 cons  */
    529         .long local_label(misc_set_invalid) /* 22 catch_frame  */
     531        .long _SPgvset /* 22 catch_frame  */
    530532        .long local_label(misc_set_invalid) /* 23 imm  */
    531533        .long local_label(misc_set_invalid) /* 24 odd_fixnum  */
     
    544546        .long local_label(misc_set_invalid) /* 30 even_fixnum  */
    545547        .long local_label(misc_set_invalid) /* 31 cons  */
    546         .long local_label(misc_set_invalid) /* 32 nodeheader  */
     548        .long _SPgvset /* 32 basic_stream  */
    547549        .long local_label(misc_set_invalid) /* 33 imm  */
    548550        .long local_label(misc_set_invalid) /* 34 odd_fixnum  */
     
    816818        __(movl %arg_z,%arg_y)
    817819        __(movl %temp0,%arg_z)
     820        __(pop %temp1)  /* return addr */
    818821        __(push $reserved_frame_marker)
    819822        __(push $reserved_frame_marker)
    820823        __(push $XNOTELT)
     824        __(push %temp1)
    821825        __(set_nargs(3))
    822826        __(jmp _SPksignalerr)
     
    915919        __(ret)
    916920local_label(misc_set_invalid):
     921        __(pop %temp1)  /* return addr */
    917922        __(push $reserved_frame_marker)
    918923        __(push $reserved_frame_marker)
    919924        __(push $XSETBADVEC)
    920925        __(push %temp0)
     926        __(push %temp1)
    921927        __(set_nargs(4))
    922928        __(jmp _SPksignalerr)
     
    17261732_endsubp(rplacd)
    17271733
    1728 /* Storing into a gvector can be handles the same way as storing into a CONS. */
     1734/* Storing into a gvector can be handled the same way as storing into a CONS. */
    17291735/* args (src, unscaled-idx, val) in temp0, arg_y, arg_z */
    17301736_spentry(gvset)
     
    17401746        __(cmpl lisp_global(oldspace_dnode_count),%imm0)
    17411747        __(jae 0b)
    1742         __(ref_global(refbits,%temp0))
     1748        __(ref_global(refbits,%temp1))
    17431749        __(xorb $31,%imm0_b)
    17441750        __(lock)
    1745         __(btsl %imm0,(%temp0))
     1751        __(btsl %imm0,(%temp1))
    17461752        __(ret)
    17471753_endsubp(gvset)
     
    17801786/* whether or not the STORE-CONDITIONAL (cmpxchgq) has won or not.    */
    17811787/* If we're interrupted   before the PC has reached the "success_test" label, */
    1782 /* repeat (luser the PC back to .SPstore_node_conditional.)  If we're at that */
     1788/* repeat (luser the PC back to store_node_conditional_retry.)  If
     1789        we're at that */
    17831790/* label with the Z flag set, we won and (may) need to memoize.  */
    17841791
     
    17891796        __(subl $misc_data_offset*fixnumone,%temp0) /* undo pre-added offset */
    17901797        __(sarl $fixnumshift,%temp0)    /* will be fixnum-tagged */
     1798        .globl C(egc_store_node_conditional_retry)
     1799C(egc_store_node_conditional_retry):     
    179118000:      __(cmpl %arg_y,misc_data_offset(%temp1,%temp0))
    17921801        __(movl misc_data_offset(%temp1,%temp0),%imm0)
     
    18201829        __(subl $misc_data_offset*fixnumone,%temp0) /* undo pre-added offset */
    18211830        __(sarl $fixnumshift,%temp0)    /* will be fixnum-tagged */
     1831        .globl C(egc_set_hash_key_conditional_retry)
     1832C(egc_set_hash_key_conditional_retry):         
    182218330:      __(cmpl %arg_y,misc_data_offset(%temp1,%temp0))
    18231834        __(movl misc_data_offset(%temp1,%temp0),%imm0)
     
    19922003        __(cmpl $tstack_alloc_limit,%imm0)
    19932004        __(ja local_label(stack_misc_alloc_heap_alloc_ivector))
     2005        __ifdef([WINDOWS])
     2006         __(windows_cstack_probe(%imm0,%temp1))
     2007        __endif
    19942008        __(movd rcontext(tcr.foreign_sp),%stack_temp)
    19952009        __(movd %stack_temp,%temp1)
     
    26922706        __(cmpl $tstack_alloc_limit,%imm0)
    26932707        __(jae 1f)
     2708        __ifdef([WINDOWS])
     2709         __(windows_cstack_probe(%imm0,%arg_z))
     2710        __endif
    26942711        __(movd rcontext(tcr.foreign_sp),%mm0)
    26952712        __(subl %imm0,rcontext(tcr.foreign_sp))
     
    27192736        __(cmpl $tstack_alloc_limit,%imm0)
    27202737        __(jae 9f)
     2738        __ifdef([WINDOWS])
     2739         __(windows_cstack_probe(%imm0,%temp0))
     2740        __endif
    27212741        __(movl rcontext(tcr.foreign_sp),%temp0)
    27222742        __(subl %imm0,rcontext(tcr.foreign_sp))
     
    41604180        __else
    41614181        __(fnstsw rcontext(tcr.ffi_exception))
     4182        __(fnclex)
    41624183        __endif
    416341841:      __(pushl rcontext(tcr.save_eflags))
     
    42464267        /* arg word 0 at 8(%ebp), word 1 at 12(%ebp), etc. */
    42474268
     4269        /* %eax is passed to us via the callback trampoline.
     4270           bits 0-22: callback index
     4271           bit 23: flag, set if we need to discard hidden arg on return
     4272                   (ignored when upper 8 bits are non-zero)
     4273           bits 24-31: arg words to discard on return (_stdcall for win32) */
     4274       
    42484275        /* Reserve some space for results, relative to the
    42494276           current %ebp.  We may need quite a bit of it. */
    4250         __(subl $24,%esp)
     4277        __(subl $20,%esp)
    42514278        __(movl $0,-16(%ebp)) /* No FP result */
     4279        __(btl $23,%eax)      /* set CF if we need to discard hidden arg */
     4280        __(pushfl)            /* and save for later */
    42524281        __(movl %eax,%ecx)    /* extract args-discard count */
    42534282        __(shrl $24,%ecx)
    4254         __(andl $0x00ffffff,%eax)
     4283        __(andl $0x007fffff,%eax) /* callback index */
    42554284        __(movl %ecx,-12(%ebp))
    42564285        /* If the C stack is 16-byte aligned by convention,
     
    43224351        __(movl -8(%ebp),%eax)
    43234352        __(movl -4(%ebp),%edx)
    4324         __(leave)
    43254353        __ifdef([WIN_32])
    43264354         __(testl %ecx,%ecx)
    43274355         __(jne local_label(winapi_return))
    4328          __(repret)
    4329         __else
    4330          __(ret)
    4331         __endif
     4356        __endif
     4357        /* since we aligned the stack after pushing flags, we're not
     4358           really sure where %esp is relative to where flags were saved.
     4359           We do know where the saved flags are relative to %ebp, so use
     4360           that to establish %esp before the popfl.
     4361        */
     4362        __(lea -24(%ebp),%esp)
     4363        __(popfl)       /* flags from bt way back when */
     4364        __(jc local_label(discard_first_arg))
     4365        __(leave)
     4366        __(ret)
    433243671:      __(jne 2f)
    43334368        /* single float return in x87 */
    43344369        __(flds -8(%ebp))
    4335         __(leave)
    43364370        __ifdef([WIN_32])
    43374371         __(testl %ecx,%ecx)
    43384372         __(jne local_label(winapi_return))
    4339          __(repret)
    4340         __else
    4341          __(ret)
    43424373        __endif
     4374        __(leave)
     4375        __(ret)
    434343762:      /* double-float return in x87 */
    43444377        __(fldl -8(%ebp))
    4345         __(leave)
    43464378        __ifdef([WIN_32])
    43474379         __(testl %ecx,%ecx)
    43484380         __(jne local_label(winapi_return))
    4349          __(repret)
    4350         __else
    4351          __(ret)
    43524381        __endif
     4382        __(leave)
     4383        __(ret)
    43534384        __ifdef([WIN_32])
    4354 local_label(winapi_return):             
     4385local_label(winapi_return):
     4386          __(leave)
    43554387         /* %ecx is non-zero and contains count of arg words to pop */
    43564388          __(popl -4(%esp,%ecx,4))
     
    43584390          __(ret)
    43594391        __endif
     4392local_label(discard_first_arg):
     4393        __(leave)
     4394        __(ret $4)
    43604395_endsubp(callback)
    43614396
  • branches/working-0711/ccl/lisp-kernel/x86-spentry64.s

    r11412 r12198  
    18541854/* whether or not the STORE-CONDITIONAL (cmpxchgq) has won or not.    */
    18551855/* If we're interrupted   before the PC has reached the "success_test" label,   */
    1856 /* repeat (luser the PC back to .SPstore_node_conditional.)  If we're at that  */
     1856/* repeat (luser the PC back to store_node_conditional_retry.)  If we're at that  */
    18571857/* label with the Z flag set, we won and (may) need to memoize.  */
    18581858
     
    18611861C(egc_store_node_conditional):
    18621862        __(unbox_fixnum(%temp0,%imm1))
     1863        .globl C(egc_store_node_conditional_retry)
     1864C(egc_store_node_conditional_retry):     
    186318650:      __(movq (%arg_x,%imm1),%temp1)
    18641866        __(cmpq %arg_y,%temp1)
     
    18901892        .globl C(egc_set_hash_key_conditional)
    18911893C(egc_set_hash_key_conditional):
     1894        .globl C(egc_set_hash_key_conditional_retry)
     1895C(egc_set_hash_key_conditional_retry):         
    18921896        __(unbox_fixnum(%temp0,%imm1))
    189318970:      __(movq (%arg_x,%imm1),%temp1)
     
    20642068        __(cmpq $tstack_alloc_limit,%imm1)
    20652069        __(ja local_label(stack_misc_alloc_heap_alloc_ivector))
     2070        __ifdef([WINDOWS])
     2071         __(windows_cstack_probe(%imm1,%temp0))
     2072        __endif
    20662073        __(movq rcontext(tcr.foreign_sp),%stack_temp)
    20672074        __(movd %stack_temp,%temp1)
     
    26762683        __(cmpq $tstack_alloc_limit,%imm0)
    26772684        __(jae 1f)
     2685        __ifdef([WINDOWS])
     2686         __(windows_cstack_probe(%imm0,%arg_z))
     2687        __endif
    26782688        __(movq rcontext(tcr.foreign_sp),%imm1)
    26792689        __(subq %imm0,rcontext(tcr.foreign_sp))
     
    27032713        __(cmpq $tstack_alloc_limit,%imm0)
    27042714        __(jae 9f)
     2715        __ifdef([WINDOWS])
     2716         __(windows_cstack_probe(%imm0,%arg_z))
     2717        __endif       
    27052718        __(movq rcontext(tcr.foreign_sp),%imm1)
    27062719        __(subq %imm0,rcontext(tcr.foreign_sp))
     
    42564269            contains the linear tcr address.  Preserve %rax/%rdx here. */
    42574270         __(set_gs_base(%csave1))
    4258          __(movq (%csave3),%rax)
    4259          __(movq 8(%csave3),%rdx)
    4260          __(movsd 16(%csave3),%xmm0)
    4261          __(movsd 24(%csave3),%xmm1)
     4271         __(movq (%csave0),%rax)
     4272         __(movq 8(%csave0),%rdx)
     4273         __(movsd 16(%csave0),%xmm0)
     4274         __(movsd 24(%csave0),%xmm1)
    42624275        __endif
    42634276        __ifdef([WINDOWS])
     
    50755088        __ifdef([DARWIN])
    50765089        .if 1
     5090        .globl  C(lisp_objc_personality)
     5091C(lisp_objc_personality):
     5092        jmp *lisp_global(objc_2_personality)
     5093       
    50775094        .section __TEXT,__eh_frame,coalesced,no_toc+strip_static_syms+live_support
    50785095EH_frame1:
     
    50865103        .byte   0x78    /* sleb128 -8; CIE Data Alignment Factor */
    50875104        .byte   0x10    /* CIE RA Column */
    5088         .byte   0xb     /* uleb128 0xb; Augmentation size */
    5089         .byte   0x8c    /* Personality (indirect  sdata8) */
    5090         .quad   lisp_global(objc_2_personality)
     5105        .byte   0x7
     5106        .byte   0x9b
     5107        .long   _lisp_objc_personality+4@GOTPCREL
    50915108        .byte   0x10    /* LSDA Encoding (pcrel) */
    50925109        .byte   0x10    /* FDE Encoding (pcrel) */
  • branches/working-0711/ccl/lisp-kernel/xlbt.c

    r10389 r12198  
    105105    } else {
    106106      if (start->backlink) {
    107         fprintf(stderr, "Bogus  frame %lx\n", start);
     107        fprintf(dbgout, "Bogus  frame %lx\n", start);
    108108      }
    109109      return;
     
    115115    }
    116116    if (next < start) {
    117       fprintf(stderr, "Bad frame! (%x < %x)\n", next, start);
     117      fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start);
    118118    &n