Changeset 11074


Ignore:
Timestamp:
Oct 13, 2008, 5:21:00 PM (11 years ago)
Author:
gz
Message:

More diff reduction, mostly mods in support of windows and/or x8632

Location:
branches/working-0711/ccl
Files:
7 added
13 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-application.lisp

    r10938 r11074  
    167167               (t "~a"))
    168168             opts)
    169      #$EX_USAGE
     169     #-windows-target #$EX_USAGE #+windows-target #$EXIT_FAILURE
    170170     (summarize-option-syntax a))))
    171171               
     
    256256  (if args
    257257    (%usage-exit (format nil "Unrecognized non-option arguments: ~a" args)
    258                  #$EX_USAGE
     258                 #-windows-target #$EX_USAGE #+windows-target #$EXIT_FAILURE
    259259                 (summarize-option-syntax a))
    260260    (progn
     
    295295  (with-standard-abort-handling nil
    296296    (loop
    297       (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*)
     297      #+windows-target (#_SleepEx 333 #$true)
     298      #-windows-target (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*)
    298299      (housekeeping))))
    299300 
     
    301302(defmethod application-init-file ((app lisp-development-system))
    302303  ;; This is the init file loaded before cocoa.
    303   #+clozure-common-lisp '("home:ccl-init" "home:openmcl-init") ;; transitional kludge
    304   #-clozure-common-lisp "home:openmcl-init")
     304  #+unix '("home:ccl-init" "home:\\.ccl-init")
     305  #+windows "home:ccl-init")
  • branches/working-0711/ccl/level-1/l1-boot-1.lisp

    r10398 r11074  
    4040    (,platform-os-solaris . :solaris)
    4141    (,platform-os-darwin . :darwin)
    42     (,platform-os-freebsd . :freebsd)))
     42    (,platform-os-freebsd . :freebsd)
     43    (,platform-os-windows . :windows)))
    4344
    4445(defparameter *platform-cpu-names*
     
    7374(defun replace-base-translation (host-dir new-base-dir)
    7475  (let* ((host (pathname-host host-dir))
     76         (device (pathname-device new-base-dir))
    7577         (host-dir (full-pathname host-dir))
    7678         (trans (logical-pathname-translations host))
     
    8890                    (merge-pathnames
    8991                     (make-pathname
    90                       :defaults nil
     92                      :defaults nil
     93                      :device device
    9194                      :directory (append new-base-dir
    9295                                         (nthcdr (length host-dir)
  • branches/working-0711/ccl/level-1/l1-boot-3.lisp

    r9578 r11074  
    2020(in-package "CCL")
    2121
    22 
    2322(catch :toplevel
    2423    (or (find-package "COMMON-LISP-USER")
     
    2625)
    2726
    28 
    2927(set-periodic-task-interval .33)
    3028(setq cmain xcmain)
    3129(setq %err-disp %xerr-disp)
    3230
    33 
    34 
    3531;;;end of l1-boot-3.lisp
    3632
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r10938 r11074  
    4141          (t (%non-standard-instance-slots instance typecode)))))
    4242
     43
     44;;; True if X is a class but not a foreign-class.
     45(defun native-class-p (x)
     46  (if (%standard-instance-p x)
     47    (< (the fixnum (instance.hash x)) max-class-ordinal)))
    4348
    4449(defun %class-name (class)
     
    906911                      (kernel-function-p (%method-function method)))))
    907912    (cerror "Replace the definition of ~S."
    908             "The method ~S is predefined in OpenMCL." method)))
     913            "The method ~S is predefined in Clozure CL." method)))
    909914
    910915;;; Called by the expansion of generic-labels.  Which doesn't exist.
     
    14341439  (%istruct 'class-ctype *class-type-class* nil class nil))
    14351440
    1436 (defun foreign-class-ordinal (class)
    1437   (error "NYI: foreign-class-ordinal for ~s" class))
    1438 
    1439 (defun (setf foreign-class-ordinal) (new class)
    1440   (error "NYI: can't set foreign-class ordinal for ~s to ~s" class new))
    1441 
    1442 
    14431441(defun %class-ordinal (class &optional no-error)
    14441442  (if (standard-instance-p class)
     
    14581456
    14591457
    1460 (defvar *t-class* (let ((class (%cons-built-in-class 't)))
    1461                     (setf (instance.hash class) 0) ;first class ordinal
     1458(defvar *t-class* (let* ((class (%cons-built-in-class 't)))
     1459                    (setf (instance.hash class) 0)
    14621460                    (let* ((cpl (list class))
    14631461                           (wrapper (%cons-wrapper class (new-class-wrapper-hash-index))))
    1464                       (setf (%class.cpl class) cpl
    1465                             (%wrapper-cpl wrapper) cpl
     1462                      (setf (%class.cpl class) cpl)
     1463                      (setf (%wrapper-cpl wrapper) cpl
     1464                            (%class.own-wrapper class) wrapper
    14661465                            (%wrapper-cpl-bits wrapper) #*1)
    1467                       (setf (%class.own-wrapper class) wrapper)
    14681466                      (setf (%class.ctype class) (make-class-ctype class))
    14691467                      (setf (find-class 't) class)
     
    15111509      (declare (fixnum max))
    15121510      (dolist (class cpl)
    1513         (let* ((ordinal (instance.hash class)))
     1511        (let* ((ordinal (%class-ordinal class)))
    15141512          (declare (fixnum ordinal))
    15151513          (when (> ordinal max)
     
    15171515      (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit)))
    15181516        (dolist (class cpl bits)
    1519           (let* ((ordinal (instance.hash class)))
     1517          (let* ((ordinal (%class-ordinal class)))
    15201518            (setf (sbit bits ordinal) 1)))))))
    15211519
     
    18781876  (defstatic *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer)))
    18791877
    1880   #+x8664-target
     1878  #+x86-target
    18811879  (defstatic *tagged-return-address-class* (make-built-in-class 'tagged-return-address))
    18821880  (make-built-in-class 'bignum (find-class 'integer))
     
    20332031            *t-class*))
    20342032
     2033  #+x8632-target
     2034  (defparameter *ivector-vector-classes*
     2035    (vector (find-class 'short-float-vector)
     2036            (find-class 'unsigned-long-vector)
     2037            (find-class 'long-vector)
     2038            (find-class 'fixnum-vector)
     2039            (find-class 'base-string)
     2040            (find-class 'unsigned-byte-vector)
     2041            (find-class 'byte-vector)
     2042            *t-class*
     2043            (find-class 'unsigned-word-vector)
     2044            (find-class 'word-vector)
     2045            (find-class 'double-float-vector)
     2046            (find-class 'bit-vector)))
     2047
    20352048  #+x8664-target
    20362049  (progn
     
    20942107                                          instance-class-wrapper
    20952108                                          class-own-wrapper
    2096                                           slots-vector)
     2109                                          slots-vector class-ordinal
     2110                                          set-class-ordinal)
    20972111    (%istruct 'foreign-object-domain index name recognize class-of classp
    2098               instance-class-wrapper class-own-wrapper slots-vector))
     2112              instance-class-wrapper class-own-wrapper slots-vector
     2113              class-ordinal set-class-ordinal))
    20992114 
    21002115  (let* ((n-foreign-object-domains 0)
     
    21082123                                           instance-class-wrapper
    21092124                                           class-own-wrapper
    2110                                            slots-vector)
     2125                                           slots-vector
     2126                                           class-ordinal
     2127                                           set-class-ordinal)
    21112128      (with-lock-grabbed (foreign-object-domain-lock)
    21122129        (dotimes (i n-foreign-object-domains)
     
    21202137                    (foreign-object-domain-class-own-wrapper already)
    21212138                    class-own-wrapper
    2122                     (foreign-object-domain-slots-vector already) slots-vector)
     2139                    (foreign-object-domain-slots-vector already) slots-vector
     2140                    (foreign-object-domain-class-ordinal already) class-ordinal
     2141                    (foreign-object-domain-set-class-ordinal already)
     2142                    set-class-ordinal)
    21232143              (return-from register-foreign-object-domain i))))
    21242144        (let* ((i n-foreign-object-domains)
     
    21332153                                                class-own-wrapper
    21342154                                                :slots-vector
    2135                                                 slots-vector)))
     2155                                                slots-vector
     2156                                                :class-ordinal class-ordinal
     2157                                                :set-class-ordinal set-class-ordinal)))
    21362158          (incf n-foreign-object-domains)
    21372159          (if (= i (length foreign-object-domains))
     
    21492171    (defun foreign-slots-vector (p)
    21502172      (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p))
     2173    (defun foreign-class-ordinal (p)
     2174      (funcall (foreign-object-domain-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p))
     2175    (defun (setf foreign-class-ordinal) (new p)
     2176      (funcall (foreign-object-domain-set-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p new))
    21512177    (defun classify-foreign-pointer (p)
    21522178      (do* ((i (1- n-foreign-object-domains) (1- i)))
     
    22662292                (%svref v (+ slice ppc64::fulltag-imm-2)) *immediate-class*
    22672293                (%svref v (+ slice ppc64::fulltag-imm-3)) *immediate-class*))
     2294        #+x8632-target
     2295        (do* ((slice 0 (+ 8 slice))
     2296              (cons-fn #'(lambda (x) (if (null x) *null-class* *cons-class*))))
     2297             ((= slice 256))
     2298          (declare (type (unsigned-byte 8) slice))
     2299          (setf (%svref v (+ slice x8632::fulltag-even-fixnum)) *fixnum-class*
     2300                (%svref v (+ slice x8632::fulltag-odd-fixnum))  *fixnum-class*
     2301                (%svref v (+ slice x8632::fulltag-cons)) cons-fn
     2302                (%svref v (+ slice x8632::fulltag-tra)) *tagged-return-address-class*
     2303                (%svref v (+ slice x8632::fulltag-imm)) *immediate-class*))
    22682304        #+x8664-target
    22692305        (do* ((slice 0 (+ 16 slice)))
     
    22852321          (map-subtag target::subtag-single-float short-float)
    22862322          (map-subtag target::subtag-dead-macptr ivector)
    2287           #-x8664-target
     2323          #-x86-target
    22882324          (map-subtag target::subtag-code-vector code-vector)
    22892325          #+ppc32-target
     
    23492385        (setf (%svref v target::subtag-instance)
    23502386              #'%class-of-instance)
    2351         (setf (%svref v #+ppc-target target::subtag-symbol #+x86-target target::tag-symbol)
     2387        (setf (%svref v #+ppc-target target::subtag-symbol
     2388                      #+x8632-target target::subtag-symbol
     2389                      #+x8664-target target::tag-symbol)
    23522390              #-ppc64-target
    23532391              #'(lambda (s) (if (eq (symbol-package s) *keyword-package*)
     
    23642402        (setf (%svref v
    23652403                      #+ppc-target target::subtag-function
    2366                       #+x86-target target::tag-function)
     2404                      #+x8632-target target::subtag-function
     2405                      #+x8664-target target::tag-function)
    23672406              class-of-function-function)
    23682407        (setf (%svref v target::subtag-vectorH)
     
    23782417                                   (- ppc32::ntagbits))
    23792418                              #+ppc64-target
    2380                               (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits)))
     2419                              (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits))
     2420                              #+x8632-target
     2421                              (ash (the fixnum (- subtype x8632::min-cl-ivector-subtag))
     2422                                   (- x8632::ntagbits)))
    23812423                      #+x8664-target
    23822424                      (let* ((class (logand x8664::fulltagmask subtype))
     
    24152457
    24162458
    2417 ;;; True if X is a class but not a foreign-class.
    2418 (defun native-class-p (x)
    2419   (if (%standard-instance-p x)
    2420     (< (the fixnum (instance.hash x)) max-class-ordinal)))
    24212459
    24222460(defun classp (x)
  • branches/working-0711/ccl/level-1/l1-dcode.lisp

    r10938 r11074  
    19571957
    19581958
    1959 
  • branches/working-0711/ccl/level-1/l1-error-signal.lisp

    r8380 r11074  
    3434  (%errno-disp-internal errno errargs (%get-frame-ptr)))
    3535
     36#+windows-target
     37(defun %windows-error-disp (errno &rest errargs)
     38  (%err-disp-common errno 0 (%windows-error-string errno) errargs (%get-frame-ptr)))
     39 
    3640(defun %errno-disp-internal (errno errargs frame-ptr)
    3741  (declare (fixnum errno))
     
    130134    (bug (format nil "Error during early application initialization:~%
    131135~a" condition))
    132     (#_exit #$EX_SOFTWARE))
     136    (#_exit #-windows-target #$EX_SOFTWARE #+windows-target #$EXIT_FAILURE))
    133137  (application-error *application* condition error-pointer)
    134138  (application-error
  • branches/working-0711/ccl/level-1/l1-events.lisp

    r6938 r11074  
    177177      (when task
    178178        (if (setq *%periodic-tasks%* (delete task *%periodic-tasks%*))
    179           (let* ((min-ticks most-positive-fixnum))
     179          (let* ((min-ticks target::target-most-positive-fixnum))
    180180            (dolist (other *%periodic-tasks%*
    181181                     (set-periodic-task-interval (/ min-ticks (float *ticks-per-second*))))
  • branches/working-0711/ccl/level-1/l1-io.lisp

    r10532 r11074  
    2222  (let* ((p (malloc size)))
    2323    (if (and clear-p (not (%null-ptr-p p)))
    24       (#_bzero p size))
     24      (#_memset p 0 size))
    2525    p))
    2626
     
    272272;; for things like *print-level* which must [no longer] be integers > 0
    273273(defun get-*print-frob* (symbol
    274                          &optional (nil-means most-positive-fixnum)
     274                         &optional (nil-means target::target-most-positive-fixnum)
    275275                         (t-means nil))
    276276  (declare (type symbol symbol))
     
    287287           nil-means)
    288288          ((and (integerp value)) ; (> value 0))
    289            (min (max value -1) value most-positive-fixnum))
     289           (min (max value -1) value target::target-most-positive-fixnum))
    290290          ((and t-means (eq value 't))
    291291           t-means)
     
    420420  (let ((print-level (get-*print-frob* '*print-level*)))
    421421    (if (not (and level print-level))
    422       most-positive-fixnum
     422      target::target-most-positive-fixnum
    423423      (if (> level print-level)
    424424        ;; wtf!
     
    594594  (write-unreadable-start object stream)
    595595  (when type
    596     (princ (type-of object) stream)
    597     (stream-write-char stream #\space))
     596    (princ (type-of object) stream))
    598597  (when thunk
     598    (when type (stream-write-char stream #\space))
    599599    (funcall thunk))
    600600  (if id
     
    12671267                                          '*print-simple-vector*
    12681268                                          0
    1269                                           most-positive-fixnum))))
     1269                                          target::target-most-positive-fixnum))))
    12701270               (pp-start-block stream "#(")
    12711271               (do ((i 0 (%i+ i 1))
     
    16591659            (slot-id.index  slot-id))))
    16601660
    1661 #+x8664-target
     1661#+x86-target
    16621662(defmethod print-object ((tra tagged-return-address) stream)
    16631663  (print-unreadable-object (tra stream :identity t :type t)
     
    17091709            (if *print-level*
    17101710              (- *print-level* *current-level*)
    1711               most-positive-fixnum)
     1711              target::target-most-positive-fixnum)
    17121712            (%current-write-level% stream t))))
    17131713  (cond
     
    17171717   (t (write-internal stream
    17181718                      object
    1719                       (min levels-left most-positive-fixnum)
     1719                      (min levels-left target::target-most-positive-fixnum)
    17201720                      nil)))
    17211721  object)
  • branches/working-0711/ccl/level-1/l1-reader.lisp

    r11069 r11074  
    30983098
    30993099(defun read-recording-source (stream &key eofval file-name start-offset map save-source-text)
    3100   "Read a top-level form, perhaps recording source location.
     3100  "Read a top-level form, perhaps recording source locations.
    31013101If MAP is NIL, just reads a form as if by READ.
    31023102If MAP is non-NIL, returns a second value of a source-note describing the form.
    31033103In addition, if MAP is a hash table, it gets filled with source-note's for all
    3104 non-atomic nested forms."
     3104non-atomic nested subforms."
    31053105  (typecase map
    31063106    (null (values (read-internal stream nil eofval nil) nil))
  • branches/working-0711/ccl/level-1/l1-sysio.lisp

    r9870 r11074  
    1818
    1919(defstruct (file-ioblock (:include ioblock))
    20   (octet-pos 0 :type fixnum)            ; current io position in octets
    21   (fileeof 0 :type fixnum)              ; file length in elements
     20  (octet-pos 0 )                       ; current io position in octets
     21  (fileeof 0 )                          ; file length in elements
    2222  )
    2323
     
    7373                        (#\Line_Separator (return :unicode))
    7474                        (#\Return (setq last-was-cr t))))))))
    75         (when line-termination
    76           (install-ioblock-input-line-termination file-ioblock line-termination)
    77           (when (file-ioblock-outbuf file-ioblock)
    78             (install-ioblock-output-line-termination file-ioblock line-termination))))))))
     75          (when line-termination
     76            (install-ioblock-input-line-termination file-ioblock line-termination)
     77            (when (file-ioblock-outbuf file-ioblock)
     78              (install-ioblock-output-line-termination file-ioblock line-termination))))))))
    7979
    8080
     
    590590(defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen)
    591591  (with-stream-ioblock-input (file-ioblock stream :speedy t)
    592     (%ioblock-input-file-length file-ioblock newlen)))
     592    (let* ((res (%ioblock-input-file-length file-ioblock newlen)))
     593      (and res (>= res 0) res))))
     594
    593595
    594596(defmethod stream-length ((stream basic-file-input-stream) &optional newlen)
    595597  (let* ((file-ioblock (basic-stream-ioblock stream)))
    596598    (with-ioblock-input-locked (file-ioblock)
    597       (%ioblock-input-file-length file-ioblock newlen))))
     599      (let* ((res (%ioblock-input-file-length file-ioblock newlen)))
     600        (and res (>= res 0) res)))))
    598601
    599602
    600603(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen)
    601604  (with-stream-ioblock-output (file-ioblock s :speedy t)
    602     (%ioblock-output-file-length file-ioblock newlen)))
     605    (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
     606      (and res (>= res 0) res))))
    603607
    604608
     
    606610  (let* ((file-ioblock (basic-stream-ioblock stream)))
    607611    (with-ioblock-output-locked (file-ioblock)
    608       (%ioblock-output-file-length file-ioblock newlen))))
     612      (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
     613        (and res (>= res 0) res)))))
    609614
    610615(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen)
    611616  (with-stream-ioblock-input (file-ioblock s :speedy t)
    612     (%ioblock-output-file-length file-ioblock newlen)))
     617    (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
     618      (and res (>= res 0) res))))
    613619
    614620(defmethod stream-length ((stream basic-file-io-stream) &optional newlen)
    615621  (let* ((file-ioblock (basic-stream-ioblock stream)))
    616622    (with-ioblock-input-locked (file-ioblock)
    617       (%ioblock-output-file-length file-ioblock newlen))))
     623      (let* ((res (%ioblock-output-file-length file-ioblock newlen)))
     624        (and res (>= res 0) res)))))
    618625
    619626(defun close-file-stream (s abort)
  • branches/working-0711/ccl/level-1/x86-error-signal.lisp

    r7892 r11074  
    1818(in-package "CCL")
    1919
     20#+x8664-target
    2021(defun xp-argument-count (xp)
    2122  (ldb (byte (- 16 x8664::fixnumshift) 0)
    2223                    (encoded-gpr-lisp xp x8664::nargs.q)))
    2324
    24 
    25 
     25#+x8632-target
     26(defun xp-argument-count (xp)
     27  (encoded-gpr-lisp xp target::nargs))
     28
     29#+x8664-target
    2630(defun xp-argument-list (xp)
    2731  (let ((nargs (xp-argument-count xp))
     
    4145                   (push (%get-object sp (* i x8664::node-size)) args))
    4246                 args)))))))
    43                          
     47
     48#+x8632-target
     49(defun xp-argument-list (xp)
     50  (let ((nargs (xp-argument-count xp))
     51        (arg-y (encoded-gpr-lisp xp x8632::arg_y))
     52        (arg-z (encoded-gpr-lisp xp x8632::arg_z)))
     53    (cond ((eql nargs 0) nil)
     54          ((eql nargs 1) (list arg-z))
     55          (t
     56           (let ((args (list arg-y arg-z)))
     57             (if (eql nargs 2)
     58               args
     59               (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8632::esp)
     60                                   (+ x8632::node-size x8632::xcf.size))))
     61                 (dotimes (i (- nargs 2))
     62                   (push (%get-object sp (* i x8632::node-size)) args))
     63                 args)))))))
     64
    4465;;; Making this be continuable is hard, because of the xcf on the
    4566;;; stack and the way that the kernel saves/restores rsp and rbp
     
    5576                  (%kernel-restart-internal
    5677                   $xudfcall
    57                    (list (maybe-setf-name (encoded-gpr-lisp xp x8664::fname)) args)
     78                   (list (maybe-setf-name (encoded-gpr-lisp xp target::fname)) args)
    5879                   frame-ptr)))
    5980         (f #'(lambda (values) (apply #'values values))))
    60     (setf (encoded-gpr-lisp xp x8664::arg_z) values
    61           (encoded-gpr-lisp xp x8664::fn) f)))
    62  
     81    (setf (encoded-gpr-lisp xp target::arg_z) values
     82          (encoded-gpr-lisp xp target::fn) f)))
     83
     84#+x8664-target
    6385(defcallback %xerr-disp (:address xp :address xcf :int)
    6486  (with-error-reentry-detection
     
    232254          skip))))
    233255
    234 
    235          
     256;;; lots of duplicated code here
     257#+x8632-target
     258(defcallback %xerr-disp (:address xp :address xcf :int)
     259  (with-error-reentry-detection
     260      (let* ((frame-ptr (macptr->fixnum xcf))
     261             (fn (%get-object xcf x8632::xcf.nominal-function))
     262             (op0 (%get-xcf-byte xcf 0))
     263             (op1 (%get-xcf-byte xcf 1))
     264             (op2 (%get-xcf-byte xcf 2)))
     265        (declare (type (unsigned-byte 8) op0 op1 op2))
     266        (let* ((skip 2))
     267          (if (and (= op0 #xcd)
     268                   (>= op1 #x70))
     269            (cond ((< op1 #x90)
     270                   (setq skip (%check-anchored-uuo xcf 3))
     271                   (setq *error-reentry-count* 0)
     272                   (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
     273                         (%slot-unbound-trap
     274                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     275                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
     276                          frame-ptr)))
     277                  ((< op1 #xa0)
     278                   (setq skip (%check-anchored-uuo xcf 2))
     279                   ;; #x9x - register X is a symbol.  It's unbound.
     280                   (%kernel-restart-internal $xvunbnd
     281                                             (list
     282                                              (encoded-gpr-lisp
     283                                               xp
     284                                               (ldb (byte 4 0) op1)))
     285                                             frame-ptr))
     286                  ((< op1 #xb0)
     287                   (setq skip (%check-anchored-uuo xcf 2))
     288                   (%err-disp-internal $xfunbnd
     289                                       (list (encoded-gpr-lisp
     290                                              xp
     291                                              (ldb (byte 4 0) op1)))
     292                                       frame-ptr))
     293                  ((< op1 #xc0)
     294                   (setq skip (%check-anchored-uuo xcf 3))
     295                   (%err-disp-internal
     296                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
     297                    (list (encoded-gpr-lisp
     298                           xp
     299                           (ldb (byte 4 0) op1))
     300                          (logandc2 op2 arch::error-type-error))
     301                    frame-ptr))
     302                  ((= op1 #xc0)
     303                   (setq skip (%check-anchored-uuo xcf 2))
     304                   (%error 'too-few-arguments
     305                           (list :nargs (xp-argument-count xp)
     306                                 :fn fn)
     307                           frame-ptr))
     308                  ((= op1 #xc1)
     309                   (setq skip (%check-anchored-uuo xcf 2))
     310                   (%error 'too-many-arguments
     311                           (list :nargs (xp-argument-count xp)
     312                                 :fn fn)
     313                           frame-ptr))
     314                  ((= op1 #xc2)
     315                   (setq skip (%check-anchored-uuo xcf 2))
     316                   (let* ((flags (xp-flags-register xp))
     317                          (nargs (xp-argument-count xp))
     318                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
     319                     (if carry-bit
     320                       (%error 'too-few-arguments
     321                               (list :nargs nargs
     322                                     :fn fn)
     323                               frame-ptr)
     324                       (%error 'too-many-arguments
     325                               (list :nargs nargs
     326                                     :fn fn)
     327                               frame-ptr))))
     328                  ((= op1 #xc3)         ;array rank
     329                   (setq skip (%check-anchored-uuo xcf 3))
     330                   (%err-disp-internal $XNDIMS
     331                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     332                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
     333                                       frame-ptr))
     334                  ((= op1 #xc6)
     335                   (setq skip (%check-anchored-uuo xcf 2))
     336                   (%error (make-condition 'type-error
     337                                           :datum (encoded-gpr-lisp xp x8632::temp0)
     338                                           :expected-type '(or symbol function)
     339                                           :format-control
     340                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
     341                           nil frame-ptr))
     342                  ((= op1 #xc7)
     343                   (handle-udf-call xp frame-ptr)
     344                   (setq skip 0))
     345                  ((or (= op1 #xc8) (= op1 #xcb))
     346                   (setq skip (%check-anchored-uuo xcf 3))
     347                   (%error (%rsc-string $xarroob)
     348                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     349                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
     350                           frame-ptr))
     351                  ((= op1 #xc9)
     352                   (setq skip (%check-anchored-uuo xcf 2))
     353                   (%err-disp-internal $xnotfun
     354                                       (list (encoded-gpr-lisp xp x8632::temp0))
     355                                       frame-ptr))
     356                  ;; #xca = uuo-error-debug-trap
     357                  ((= op1 #xcc)
     358                   ;; external entry point or foreign variable
     359                   (setq skip (%check-anchored-uuo xcf 3))
     360                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
     361                     (etypecase eep-or-fv
     362                       (external-entry-point
     363                        (resolve-eep eep-or-fv)
     364                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
     365                              (eep.address eep-or-fv)))
     366                       (foreign-variable
     367                        (resolve-foreign-variable eep-or-fv)
     368                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
     369                              (fv.addr eep-or-fv))))))
     370                  ((< op1 #xe0)
     371                   (setq skip (%check-anchored-uuo xcf 3))
     372                   (if (= op2 x8632::subtag-catch-frame)
     373                     (%error (make-condition 'cant-throw-error
     374                                             :tag (encoded-gpr-lisp
     375                                                   xp
     376                                                   (ldb (byte 4 0) op1)))
     377                             nil frame-ptr)
     378                     (let* ((typename
     379                             (cond ((= op2 x8632::tag-fixnum) 'fixnum)
     380                                   ((= op2 x8632::subtag-character) 'character)
     381                                   ((= op2 x8632::fulltag-cons) 'cons)
     382                                   ((= op2 x8632::tag-misc) 'uvector)
     383                                   (t (let* ((class (logand op2 x8632::fulltagmask))
     384                                             (high5 (ash op2 (- x8632::ntagbits))))
     385                                        (cond ((= class x8632::fulltag-nodeheader)
     386                                               (svref *nodeheader-types* high5))
     387                                              ((= class x8632::fulltag-immheader)
     388                                               (svref *immheader-types* high5))
     389                                              (t (list 'bogus op2))))))))
     390                       (%error (make-condition 'type-error
     391                                               :datum (encoded-gpr-lisp
     392                                                       xp
     393                                                       (ldb (byte 4 0) op1))
     394                                               :expected-type typename)
     395                               nil
     396                               frame-ptr))))
     397                  ((< op1 #xf0)
     398                   (setq skip (%check-anchored-uuo xcf 2))
     399                   (%error (make-condition 'type-error
     400                                           :datum (encoded-gpr-lisp
     401                                                   xp
     402                                                   (ldb (byte 4 0) op1))
     403                                           :expected-type 'list)
     404                           nil
     405                           frame-ptr))
     406                  (t
     407                   (setq skip (%check-anchored-uuo xcf 2))
     408                   (%error (make-condition 'type-error
     409                                           :datum (encoded-gpr-lisp
     410                                                   xp
     411                                                   (ldb (byte 4 0) op1))
     412                                           :expected-type 'fixnum)
     413                           nil
     414                           frame-ptr)))
     415            (%error "Unknown trap: #x~x~%xp=~s"
     416                    (list (list op0 op1 op2) xp)
     417                    frame-ptr))
     418          skip))))
    236419                 
    237                  
    238                
    239                
    240                  
    241 
    242 
    243 
    244 
    245 
    246                    
    247                
    248            
  • branches/working-0711/ccl/level-1/x86-threads-utils.lisp

    r5067 r11074  
    4242
    4343(defun catch-frame-sp (catch)
    44   (uvref catch x8664::catch-frame.rbp-cell))
     44  (uvref catch
     45         #+x8632-target x8632::catch-frame.ebp-cell
     46         #+x8664-target x8664::catch-frame.rbp-cell))
    4547
    4648;;; Sure would be nice to have &optional in defppclapfunction arglists
     
    100102
    101103
    102 
     104#+x8632-target
     105(defun valid-subtag-p (subtag)
     106  (declare (fixnum subtag))
     107  (let* ((tagval (ldb (byte (- x8632::num-subtag-bits x8632::ntagbits) x8632::ntagbits) subtag)))
     108    (declare (fixnum tagval))
     109    (case (logand subtag x8632::fulltagmask)
     110      (#. x8632::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
     111      (#. x8632::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
     112      (t nil))))
     113
     114#+x8664-target
    103115(defun valid-subtag-p (subtag)
    104116  (declare (fixnum subtag))
     
    120132               (t 'bogus))))))
    121133
     134#+x8632-target
     135(defun valid-header-p (thing)
     136  (let* ((fulltag (fulltag thing)))
     137    (declare (fixnum fulltag))
     138    (case fulltag
     139      (#.x8632::fulltag-misc (valid-subtag-p (typecode thing)))
     140      ((#.x8632::fulltag-immheader #.x8632::fulltag-nodeheader) nil)
     141      (t t))))
     142
     143#+x8664-target
    122144(defun valid-header-p (thing)
    123145  (let* ((fulltag (fulltag thing)))
     
    138160        #.x8664::fulltag-tra-1)
    139161       (let* ((disp (%return-address-offset thing)))
    140          (or (eql 0 disp)
    141              (let* ((f (%return-address-function thing)))
    142                (and (typep f 'function) (valid-header-p f))))))
     162         (and disp
     163              (let* ((f (%return-address-function thing)))
     164                (and (typep f 'function) (valid-header-p f))))))
    143165      (#.x8664::fulltag-cons t)
    144166      (#.x8664::fulltag-nil (null thing))
    145167      (t nil))))
    146168             
    147      
    148                                      
    149                
    150 
    151 
     169#+x8632-target
     170(defun bogus-thing-p (x)
     171  (when x
     172    (or (not (valid-header-p x))
     173        (let ((tag (lisptag x))
     174              (fulltag (fulltag x)))
     175          (unless (or (eql tag x8632::tag-fixnum)
     176                      (eql tag x8632::tag-imm)
     177                      (in-any-consing-area-p x)
     178                      (temporary-cons-p x)
     179                      (and (or (typep x 'function)
     180                               (typep x 'gvector))
     181                           (on-any-tsp-stack x))
     182                      (and (eql fulltag x8632::fulltag-tra)
     183                           (%return-address-offset x))
     184                      (and (typep x 'ivector)
     185                           (on-any-csp-stack x))
     186                      (%heap-ivector-p x))
     187            t)))))
     188
     189#+x8664-target
    152190(defun bogus-thing-p (x)
    153191  (when x
  • branches/working-0711/ccl/level-1/x86-trap-support.lisp

    r10938 r11074  
    130130      )))
    131131
     132#+solarisx8664-target
     133(progn
     134  (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext)
     135                                 (get-field-offset :mcontext_t.gregs)))
     136  (defmacro xp-gp-regs (xp) xp)
     137  (defconstant flags-register-offset #$REG_RFL)
     138  (defconstant rip-register-offset #$REG_RIP)
     139  (defun xp-mxcsr (xp)
     140    (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
     141  (defparameter *encoded-gpr-to-indexed-gpr*
     142    #(14                                ;rax
     143      13                                ;rcx
     144      12                                ;rdx
     145      11                                ;rbx
     146      20                                ;rsp
     147      10                                ;rbp
     148      9                                 ;rsi
     149      8                                 ;rdi
     150      7                                 ;r8
     151      6                                 ;r9
     152      5                                 ;r10
     153      4                                 ;r11
     154      3                                 ;r12
     155      2                                 ;r13
     156      1                                 ;r14
     157      0                                 ;r15
     158      )))
     159
     160#+win64-target
     161(progn
     162  (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax))
     163  (defmacro xp-gp-regs (xp) xp)
     164  (defconstant rip-register-offset 16)
     165  (defun xp-mxcsr (xp)
     166    (pref xp #>CONTEXT.MxCsr))
     167  (defparameter *encoded-gpr-to-indexed-gpr*
     168    #(0                                 ;rax
     169      1                                 ;rcx
     170      2                                 ;rdx
     171      3                                 ;rbx
     172      4                                 ;rsp
     173      5                                 ;rbp
     174      6                                 ;rsi
     175      7                                 ;rdi
     176      8                                 ;r8
     177      9                                 ;r9
     178      10                                ;r10
     179      11                                ;r11
     180      12                                ;r12
     181      13                                ;r13
     182      14                                ;r14
     183      15                                ;r15
     184      )))
     185
     186#+darwinx8632-target
     187(progn
     188  (defconstant gp-regs-offset 0)
     189  (defmacro xp-gp-regs (xp)
     190    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext.ss))
     191  (defun xp-mxcsr (xp)
     192    (%get-unsigned-long (pref (pref xp :ucontext.uc_mcontext) :mcontext.fs) 32))
     193  (defconstant flags-register-offset 9)
     194  (defconstant eip-register-offset 10)
     195  (defparameter *encoded-gpr-to-indexed-gpr*
     196    #(0                                 ;eax
     197      2                                 ;ecx
     198      3                                 ;edx
     199      1                                 ;ebx
     200      7                                 ;esp
     201      6                                 ;ebp
     202      5                                 ;esi
     203      4                                 ;edi
     204      )))
     205
     206#+linuxx8632-target
     207(progn
     208  (defconstant gp-regs-offset 0)
     209  (defmacro xp-gp-regs (xp)
     210    `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs))
     211  (defun xp-mxcsr (xp)
     212    (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs)
     213          :_fpstate.mxcsr))
     214  (defconstant flags-register-offset #$REG_EFL)
     215  (defconstant eip-register-offset #$REG_EIP)
     216  (defparameter *encoded-gpr-to-indexed-gpr*
     217    (vector
     218     #$REG_EAX                         ;eax
     219      #$REG_ECX                         ;ecx
     220      #$REG_EDX                         ;edx
     221      #$REG_EBX                         ;ebx
     222      #$REG_ESP                         ;esp
     223      #$REG_EBP                         ;ebp
     224      #$REG_ESI                         ;esi
     225      #$REG_EDI                         ;edi
     226      )))
     227
     228#+win32-target
     229(progn
     230  (defconstant gp-regs-offset 0)
     231  (defmacro xp-gp-regs (xp)
     232    `,xp)
     233  (defun xp-mxcsr (xp)
     234    (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24))
     235  (defconstant flags-register-offset 48)
     236  (defconstant eip-register-offset 45)
     237  (defparameter *encoded-gpr-to-indexed-gpr*
     238    #(
     239     44                                ;eax
     240     43                                ;ecx
     241     42                                ;edx
     242     41                                ;ebx
     243     49                                ;esp
     244     45                                ;ebp
     245     40                                ;esi
     246     39                                ;edi
     247      )))
     248
    132249(defun indexed-gpr-lisp (xp igpr)
    133   (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
     250  (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
    134251(defun (setf indexed-gpr-lisp) (new xp igpr)
    135   (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)) new))
     252  (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new))
    136253(defun encoded-gpr-lisp (xp gpr)
    137254  (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
     
    139256  (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
    140257(defun indexed-gpr-integer (xp igpr)
    141   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
     258  #+x8664-target
     259  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
     260  #+x8632-target
     261  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))))
    142262(defun (setf indexed-gpr-integer) (new xp igpr)
    143263  (setf
     264   #+x8664-target
    144265   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift)))
     266   #+x8632-target
     267   (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))
    145268   new))
    146269(defun encoded-gpr-integer (xp gpr)
     
    149272  (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
    150273(defun indexed-gpr-macptr (xp igpr)
    151   (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))))
     274  (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))))
    152275(defun (setf indexed-gpr-macptr) (new xp igpr)
    153   (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) new))
     276  (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new))
    154277(defun encoded-gpr-macptr (xp gpr)
    155278  (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)))
     
    157280  (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new))
    158281(defun xp-flags-register (xp)
    159   (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift))))
     282  #+windows-target (pref xp #>CONTEXT.EFlags)
     283  #-windows-target
     284  (progn
     285  #+x8664-target
     286  (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift)))
     287  #+x8632-target
     288  (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift)))))
    160289 
    161290
    162291
    163292(defun %get-xcf-byte (xcf-ptr delta)
    164   (let* ((containing-object (%get-object xcf-ptr x8664::xcf.containing-object))
    165          (byte-offset (%get-object xcf-ptr x8664::xcf.relative-pc)))
     293  (let* ((containing-object (%get-object xcf-ptr target::xcf.containing-object))
     294         (byte-offset (%get-object xcf-ptr target::xcf.relative-pc)))
    166295    (if containing-object
    167296      (locally (declare (optimize (speed 3) (safety 0))
     
    175304(defun %check-anchored-uuo (xcf skip)
    176305  (if (eql 0 (%get-xcf-byte xcf skip))
    177     (let* ((new-rpc (+ target::tag-function
     306    (let* ((new-rpc (+ #+x8664-target target::tag-function
     307                       #+x8632-target target::fulltag-misc
    178308                       (logior (ash (%get-xcf-byte xcf -1) 24)
    179309                               (ash (%get-xcf-byte xcf -2) 16)
    180310                               (ash (%get-xcf-byte xcf -3) 8)
    181311                               (%get-xcf-byte xcf -4)))))
    182       (%set-object xcf x8664::xcf.relative-pc new-rpc)
     312      (%set-object xcf target::xcf.relative-pc new-rpc)
    183313      -1)
    184314    skip))
     
    188318  (declare (ignore xp xcf))
    189319  (values 'unknown nil))
     320
     321(eval-when (:compile-toplevel :execute)
     322  (progn
     323    (defun conditional-os-constant (alternatives)
     324      (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives))
     325        (if (load-os-constant c t)
     326          (return (load-os-constant c)))))
     327
     328    (defconstant integer-divide-by-zero-code
     329      (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV))
     330)
     331    (defconstant float-divide-by-zero-code
     332      (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV)))
     333    (defconstant float-overflow-code
     334      (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW)))
     335    (defconstant float-underflow-code
     336      (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW)))
     337    (defconstant float-inexact-code
     338      (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT)))))
    190339
    191340;;; UUOs are handled elsewhere.  This should handle all signals other than
     
    203352               (decode-arithmetic-error xp xcf)
    204353             (let* ((condition-name
    205                      (cond ((or (= code #$FPE_INTDIV)
    206                                 (= code #$FPE_FLTDIV))
     354                     (cond ((or (= code integer-divide-by-zero-code)
     355                                (= code float-divide-by-zero-code))
    207356                            'division-by-zero)
    208                            ((= code #$FPE_FLTOVF)
     357                           ((= code float-overflow-code)
    209358                            'floating-point-overflow)
    210                            ((= code #$FPE_FLTUND)
     359                           ((= code float-underflow-code)
    211360                            'floating-point-underflow)
    212                            ((= code #$FPE_FLTRES)
     361                           ((= code float-inexact-code)
    213362                            'floating-point-inexact)
    214363                           (t
     
    235384                        :unsigned-fullword code
    236385                        :void))))
    237           ((= signal #$SIGBUS)
     386          ((= signal #+win32-target 10 #-win32-target #$SIGBUS)
    238387           (%error (make-condition 'invalid-memory-access
    239388                    :address addr
Note: See TracChangeset for help on using the changeset viewer.