Changeset 11267


Ignore:
Timestamp:
Oct 30, 2008, 6:51:44 PM (11 years ago)
Author:
gz
Message:

Some changes from trunk in suport of other platforms, shouldn't affect anything here

Location:
branches/working-0711/ccl
Files:
45 edited
1 copied

Legend:

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

    r10972 r11267  
    110110(pushnew *win32-backend* *known-x8632-backends* :key #'backend-name)
    111111
     112#+solaris-target
     113(defvar *solaris-x8632-backend*
     114  (make-backend :lookup-opcode 'lookup-x86-opcode
     115                :lookup-macro #'false
     116                :lap-opcodes x86::*x86-opcode-templates*
     117                :define-vinsn 'define-x86-vinsn
     118                :p2-dispatch *x862-specials*
     119                :p2-vinsn-templates *x8632-vinsn-templates*
     120                :p2-template-hash-name '*x8632-vinsn-templates*
     121                :p2-compile 'x862-compile
     122                :platform-syscall-mask (logior platform-os-solaris platform-cpu-x86 platform-word-size-32)
     123                :target-specific-features
     124                '(:x8632 :x86-target :solaris-target :x8632-target
     125                  :solarisx8632-target
     126                  :little-endian-target
     127                  :32-bit-target)
     128                :target-fasl-pathname (make-pathname :type "sx32fsl")
     129                :target-platform (logior platform-cpu-x86
     130                                         platform-os-solaris
     131                                         platform-word-size-32)
     132                :target-os :solarisx8632
     133                :name :solarisx8632
     134                :target-arch-name :x8632
     135                :target-foreign-type-data nil
     136                :target-arch x8632::*x8632-target-arch*
     137                :lisp-context-register x8632::fs
     138                :num-arg-regs 2
     139                ))
     140#+solaris-target
     141(pushnew *solaris-x8632-backend* *known-x8632-backends* :key #'backend-name)
    112142
    113143(defvar *x8632-backend* (car *known-x8632-backends*))
     
    181211                           :callback-return-value-function
    182212                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "WIN32")))
     213                (:solarisx8632
     214                 (make-ftd :interface-db-directory "ccl:solarisx86-headers;"
     215                           :interface-package-name "X86-SOLARIS32"
     216                           :attributes '(:bits-per-word  32
     217                                         :signed-char nil
     218                                         :struct-by-value t
     219                                         :float-results-in-x87 t)
     220                           :ff-call-expand-function
     221                           (intern "EXPAND-FF-CALL" "X86-SOLARIS32")
     222                           :ff-call-struct-return-by-implicit-arg-function
     223                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
     224                                   "X86-SOLARIS32")
     225                           :callback-bindings-function
     226                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-SOLARIS32")
     227                           :callback-return-value-function
     228                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-SOLARIS32")))
    183229                )))
    184230        (install-standard-foreign-types ftd)
  • branches/working-0711/ccl/compiler/X86/x86-asm.lisp

    r10972 r11267  
    42834283  (let* ((reg-num (reg-entry-reg-num entry))
    42844284         (xreg-num (logior reg-num
    4285                            (if (logtest +regrex+ (reg-entry-reg-flags entry))
     4285                           (if
     4286                             (ccl::target-arch-case
     4287                              (:x8664
     4288                               (logtest +regrex+ (reg-entry-reg-flags entry)))
     4289                              (:x8632 t))
    42864290                             #x08
    42874291                             #x00))))
  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

    r11089 r11267  
    22302230(defun x86-dis-do-uuo (ds instruction intop)
    22312231  (declare (type (unsigned-byte 8) intop))
    2232   (let* ((stop t))
     2232  (let* ((stop t)
     2233         (regmask (if (x86-ds-mode-64 ds) #xf #x7)))
    22332234    (cond ((and (>= intop #x70) (< intop #x80))
    22342235           (let* ((pseudo-modrm-byte (x86-ds-next-u8 ds)))
     
    22362237                   "uuo-error-slot-unbound"
    22372238                   (x86-di-op0 instruction)
    2238                    (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%))                     
     2239                   (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))                     
    22392240                   (x86-di-op1 instruction)
    22402241                   (x86-dis-make-reg-operand (lookup-x86-register (ldb (byte 4 4)
     
    22512252                 "uuo-error-unbound"
    22522253                 (x86-di-op0 instruction)
    2253                  (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%))))
     2254                 (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))))
    22542255          ((< intop #xb0)
    22552256           (setf (x86-di-mnemonic instruction)
    22562257                 "uuo-error-udf"
    22572258                 (x86-di-op0 instruction)
    2258                  (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%))))
     2259                 (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))))
    22592260         
    22602261          ((< intop #xc0)
     
    22622263                 "uuo-error-reg-not-type"
    22632264                 (x86-di-op0 instruction)
    2264                  (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%))
     2265                 (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))
    22652266                 (x86-di-op1 instruction)
    22662267                 (x86::make-x86-immediate-operand :value (parse-x86-lap-expression (x86-ds-next-u8 ds)))))
     
    23322333                 "uuo-error-reg-not-tag"
    23332334                 (x86-di-op0 instruction)
    2334                  (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%))
     2335                 (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))
    23352336                 (x86-di-op1 instruction)
    23362337                 (x86::make-x86-immediate-operand :value (parse-x86-lap-expression (x86-ds-next-u8 ds)))))
     
    23392340                 "uuo-error-reg-not-list"
    23402341                 (x86-di-op0 instruction)
    2341                  (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%))))
     2342                 (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%))))
    23422343          (t
    23432344           (setf (x86-di-mnemonic instruction)
    23442345                 "uuo-error-reg-not-fixnum"
    23452346                 (x86-di-op0 instruction)
    2346                  (x86-dis-make-reg-operand (lookup-x86-register (logand intop #xf) :%)))))
     2347                 (x86-dis-make-reg-operand (lookup-x86-register (logand intop regmask) :%)))))
    23472348    stop))
    23482349
  • branches/working-0711/ccl/compiler/nx1.lisp

    r11164 r11267  
    13571357      (:linuxppc32 (%nx1-operator eabi-ff-call))
    13581358      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
    1359       ((:darwinx8632 :linuxx8632 :win32) (%nx1-operator i386-ff-call))
     1359      ((:darwinx8632 :linuxx8632 :win32 :solarisx8632) (%nx1-operator i386-ff-call))
    13601360      ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call)))))
    13611361
  • branches/working-0711/ccl/level-0/l0-init.lisp

    r11069 r11267  
    9898    #+solarisx8664-target :solarisx8664-target
    9999    #+solarisx8664-target :solarisx8664-host
     100    #+solarisx8632-target :solarix8632-target
     101    #+solarisx8632-target :solarisx8632-host
    100102    #+poweropen-target :poweropen-target
    101103    #+64-bit-target :64-bit-target
  • branches/working-0711/ccl/level-0/l0-io.lisp

    r11089 r11267  
    195195
    196196
    197 (defun fd-open (path flags &optional (create-mode #o666))
    198   (#+darwin-target with-utf-8-cstrs
    199    #+windows-target with-native-utf-16-cstrs
    200    #-(or darwin-target windows-target) with-cstrs
    201    ((p path))
    202     (let* ((fd (int-errno-ffcall
     197(let* ((pathname-encoding-name ()))
     198  (declare (ignorable pathname-encoding-name))
     199  (defun pathname-encoding-name ()
     200    #+darwin-target :utf-8
     201    #+windows-target :utf-16le
     202    #-(or darwin-target windows-target) pathname-encoding-name)
     203  (defun set-pathname-encoding-name (new)
     204    #+(or darwin-target windows-target) (declare (ignore new))
     205    #+darwin-target :utf-8
     206    #+windows-target :utf-16le
     207    #-(or darwin-target windows-target)
     208    (let* ((encoding (ensure-character-encoding new)))
     209      (setq pathname-encoding-name
     210            (unless (eq encoding (get-character-encoding nil))
     211              (character-encoding-name encoding))))))
     212
     213
     214(defun fd-open-path (p flags create-mode)
     215  (let* ((fd (int-errno-ffcall
     216              (%kernel-import target::kernel-import-lisp-open)
     217              :address p :int flags :mode_t create-mode :int)))
     218    (declare (fixnum fd))
     219    (when (or (= fd (- #$EMFILE))
     220              (= fd (- #$EMFILE)))
     221      (gc)
     222      (drain-termination-queue)
     223      (setq fd (int-errno-ffcall
    203224                (%kernel-import target::kernel-import-lisp-open)
    204225                :address p :int flags :mode_t create-mode :int)))
    205       (declare (fixnum fd))
    206       (when (or (= fd (- #$EMFILE))
    207                 (= fd (- #$EMFILE)))
    208         (gc)
    209         (drain-termination-queue)
    210         (setq fd (int-errno-ffcall
    211                   (%kernel-import target::kernel-import-lisp-open)
    212                            :address p :int flags :mode_t create-mode :int)))
    213       fd)))
     226    fd))
     227
     228(defun fd-open (path flags &optional (create-mode #o666))
     229  #+darwin-target (with-utf-8-cstrs ((p path))
     230                    (fd-open-path p flags create-mode))
     231  #+windows-target (with-native-utf-16-cstrs ((p path))
     232                     (fd-open-path p flags create-mode))
     233  #-(or darwin-target windows-target)
     234  (let* ((encoding (pathname-encoding-name)))
     235    (if encoding
     236      (with-encoded-cstrs encoding ((p path))
     237        (fd-open-path p flags create-mode))
     238      (with-cstrs ((p path))
     239        (fd-open-path p flags create-mode)))))
    214240
    215241(defun fd-chmod (fd mode)
  • branches/working-0711/ccl/level-1/l1-boot-2.lisp

    r11089 r11267  
    278278      #+win32-target
    279279      (bin-load-provide "FFI-WIN32" "ffi-win32")
     280      #+solarisx8632-target
     281      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
    280282     
    281283      (bin-load-provide "DB-IO" "db-io")
  • branches/working-0711/ccl/level-1/l1-callbacks.lisp

    r11101 r11267  
    2323
    2424;;; (defcallback ...) expands into a call to this function.
    25 (defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) monitor-exception-ports
    26                                                    &aux name trampoline)
     25(defun define-callback-function (lisp-function  &optional doc-string (without-interrupts t) (info 0) &aux name trampoline)
    2726  (unless (functionp lisp-function)
    2827    (setq lisp-function (require-type lisp-function 'function)))
     
    5958                       (unless (%svref %pascal-functions% i)
    6059                         (return i)))))
    61           (setq trampoline (make-callback-trampoline index))
     60          (setq trampoline (make-callback-trampoline index (or info 0)))
    6261          (setf (%svref %pascal-functions% index)
    63                 (%cons-pfe trampoline monitor-exception-ports lisp-function name without-interrupts)))))
     62                (%cons-pfe trampoline info lisp-function name without-interrupts)))))
    6463    ;;(%proclaim-special name)          ;
    6564    ;; already done by defpascal expansion
  • branches/working-0711/ccl/level-1/l1-numbers.lisp

    r11101 r11267  
    705705    (%setf-short-float result TEMP)))
    706706
     707#+(and 32-bit-target windows-target)
     708(defun %single-float-exp! (n result)
     709  (declare (single-float n result))
     710  (target::with-stack-short-floats ((temp))
     711    (%setf-short-float TEMP (external-call "expf" :single-float n :single-float))
     712    (%sf-check-exception-1 'exp n (%ffi-exception-status))
     713    (%setf-short-float result TEMP)))
     714
    707715#+64-bit-target
    708716(defun %single-float-exp (n)
  • branches/working-0711/ccl/level-1/l1-processes.lisp

    r11164 r11267  
    141141  (:primary-p t))
    142142
     143(defparameter *print-process-whostate* t "make it optional")
     144
    143145(defmethod print-object ((p process) s)
    144146  (print-unreadable-object (p s :type t :identity t)
    145     (format s "~a(~d) [~a]" (process-name p)
    146             (process-serial-number p)(process-whostate p))))
     147    (format s "~a(~d)" (process-name p)
     148            (process-serial-number p))
     149    (when *print-process-whostate*
     150      (format s " [~a]" (process-whostate p)))))
    147151
    148152(defvar *process-class* (find-class 'process))
  • branches/working-0711/ccl/level-1/l1-sockets.lisp

    r11101 r11267  
    566566  #+windows-target
    567567  (rlet ((argp :u_long (if block-flag 0 1)))
    568     (#_ioctlsocket fd #.(u32->s32 #$FIONBIO) argp))
     568    (#_ioctlsocket fd #$FIONBIO argp))
    569569  #-windows-target
    570570  (if block-flag
  • branches/working-0711/ccl/level-1/l1-unicode.lisp

    r9633 r11267  
    48354835                 string)
    48364836        string))))
    4837        
     4837
     4838
     4839(defun get-encoded-cstring (encoding-name pointer)
     4840  (let* ((encoding (ensure-character-encoding encoding-name)))
     4841    (get-encoded-string
     4842     encoding
     4843     pointer
     4844     (ecase (character-encoding-code-unit-size encoding)
     4845       (8 (%cstrlen pointer))
     4846       (16 (do* ((i 0 (+ i 2)))
     4847                ((= 0 (%get-unsigned-word pointer i))
     4848                 (return i))
     4849             (declare (fixnum i))))
     4850       (32 (do* ((i 0 (+ i 4)))
     4851                ((= 0 (%get-unsigned-long pointer i))
     4852                 (return i))
     4853             (declare (fixnum i))))))))
     4854   
    48384855
    48394856     
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r11164 r11267  
    11371137
    11381138
     1139(defsetf pathname-encoding-name set-pathname-encoding-name)
     1140
    11391141;end of L1-utils.lisp
    11401142
  • branches/working-0711/ccl/level-1/linux-files.lisp

    r11164 r11267  
    5252  ;; encoding (though FreeBSD seems to be moving towards
    5353  ;; precomposed UTF-8.).
    54   ;; In any case, the use of %GET-CSTRING here is wrong ...
    5554  #-(or darwin-target windows-target)
    56   (%get-cstring pointer))
     55  (let* ((encoding-name (pathname-encoding-name)))
     56    (if encoding-name
     57      (get-encoded-cstring encoding-name pointer)
     58      (%get-cstring pointer))))
    5759
    5860(defun nanoseconds (n)
     
    12041206  (let* ((signaled nil))
    12051207    (unwind-protect
    1206          (let* ((child-pid (#_fork)))
     1208         (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall)))
    12071209           (declare (fixnum child-pid))
    12081210           (cond ((zerop child-pid)
  • branches/working-0711/ccl/level-1/ppc-callback-support.lisp

    r6948 r11267  
    2626;;; which calls a subprim in the lisp kernel.)
    2727#-(and linuxppc-target poweropen-target)
    28 (defun make-callback-trampoline (index &optional monitor-exception-ports)
    29   (declare (ignorable monitor-exception-ports))
     28(defun make-callback-trampoline (index &optional info)
     29  (declare (ignorable info))
    3030  (macrolet ((ppc-lap-word (instruction-form)
    3131               (uvref (uvref (compile nil `(lambda (&lap 0) (ppc-lap-function () ((?? 0)) ,instruction-form))) 0) #+ppc32-host 0 #+ppc64-host 1)))
     
    3434             #.(subprim-name->offset '.SPeabi-callback)
    3535             #-eabi-target
    36              (if monitor-exception-ports
    37                #.(subprim-name->offset '.SPpoweropen-callbackX)
    38                #.(subprim-name->offset '.SPpoweropen-callback)))
     36             #.(subprim-name->offset '.SPpoweropen-callback))
    3937           (p (%allocate-callback-pointer 12)))
    4038      (setf (%get-long p 0) (logior (ldb (byte 8 16) index)
     
    5755;;; TOC word in the transfer vector to store the callback index.
    5856#+(and linuxppc-target poweropen-target)
    59 (defun make-callback-trampoline (index &optional monitor-exception-ports)
    60   (declare (ignorable monitor-exception-ports))
     57(defun make-callback-trampoline (index &optional info)
     58  (declare (ignorable info))
    6159  (let* ((p (%allocate-callback-pointer 16)))
    6260    (setf (%%get-unsigned-longlong p 0) #.(subprim-name->offset '.SPpoweropen-callback)
  • branches/working-0711/ccl/level-1/x86-callback-support.lisp

    r11101 r11267  
    1919
    2020#+x8664-target 
    21 (defun make-callback-trampoline (index &optional monitor-exception-ports)
    22   (declare (ignorable monitor-exception-ports))
     21(defun make-callback-trampoline (index &optional discard-stack-bytes)
     22  (declare (ignore discard-stack-bytes))
    2323  (let* ((p (%allocate-callback-pointer 16))
    2424         (addr #.(subprim-name->offset '.SPcallback)))
     
    4040         
    4141#+x8632-target         
    42 (defun make-callback-trampoline (index &optional monitor-exception-ports)
    43   (declare (ignorable monitor-exception-ports))
     42(defun make-callback-trampoline (index &optional (discard-stack-bytes 0))
    4443  (let* ((p (%allocate-callback-pointer 12))
    4544         (addr #.(subprim-name->offset '.SPcallback)))
     
    4847          (%get-unsigned-byte p 2) (ldb (byte 8 8) index)
    4948          (%get-unsigned-byte p 3) (ldb (byte 8 16) index)
    50           (%get-unsigned-byte p 4) (ldb (byte 8 24) index)
     49          (%get-unsigned-byte p 4) (ldb (byte 8 0) (ash (or discard-stack-bytes 0) (- x8632::word-shift)))
    5150          (%get-unsigned-byte p 5) #xff  ; jmp *
    5251          (%get-unsigned-byte p 6) #x24
  • branches/working-0711/ccl/level-1/x86-error-signal.lisp

    r11074 r11267  
    270270                   (setq skip (%check-anchored-uuo xcf 3))
    271271                   (setq *error-reentry-count* 0)
    272                    (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
     272                   (setf (encoded-gpr-lisp xp (ldb (byte 3 0) op1))
    273273                         (%slot-unbound-trap
    274274                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
     
    282282                                              (encoded-gpr-lisp
    283283                                               xp
    284                                                (ldb (byte 4 0) op1)))
     284                                               (ldb (byte 3 0) op1)))
    285285                                             frame-ptr))
    286286                  ((< op1 #xb0)
     
    289289                                       (list (encoded-gpr-lisp
    290290                                              xp
    291                                               (ldb (byte 4 0) op1)))
     291                                              (ldb (byte 3 0) op1)))
    292292                                       frame-ptr))
    293293                  ((< op1 #xc0)
     
    297297                    (list (encoded-gpr-lisp
    298298                           xp
    299                            (ldb (byte 4 0) op1))
     299                           (ldb (byte 3 0) op1))
    300300                          (logandc2 op2 arch::error-type-error))
    301301                    frame-ptr))
     
    374374                                             :tag (encoded-gpr-lisp
    375375                                                   xp
    376                                                    (ldb (byte 4 0) op1)))
     376                                                   (ldb (byte 3 0) op1)))
    377377                             nil frame-ptr)
    378378                     (let* ((typename
     
    391391                                               :datum (encoded-gpr-lisp
    392392                                                       xp
    393                                                        (ldb (byte 4 0) op1))
     393                                                       (ldb (byte 3 0) op1))
    394394                                               :expected-type typename)
    395395                               nil
     
    400400                                           :datum (encoded-gpr-lisp
    401401                                                   xp
    402                                                    (ldb (byte 4 0) op1))
     402                                                   (ldb (byte 3 0) op1))
    403403                                           :expected-type 'list)
    404404                           nil
     
    409409                                           :datum (encoded-gpr-lisp
    410410                                                   xp
    411                                                    (ldb (byte 4 0) op1))
     411                                                   (ldb (byte 3 0) op1))
    412412                                           :expected-type 'fixnum)
    413413                           nil
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r11164 r11267  
    276276     directoryp
    277277
     278
    278279     *module-search-path*
    279280     *module-provider-functions*
     
    283284     *default-external-format*
    284285     *default-line-termination*
     286     pathname-encoding-name
     287     with-filename-cstrs
     288     get-foreign-namestring
    285289     fasl-concatenate
    286290     event-ticks
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r11164 r11267  
    141141             (:win64 'ffi-win64)
    142142             (:linuxx8632 'ffi-linuxx8632)
    143              (:win32 'ffi-win32)))))
     143             (:win32 'ffi-win32)
     144             (:solarisx8632 'ffi-solarisx8632)))))
    144145
    145146
     
    224225               ppc-threads-utils ppc-callback-support))
    225226            ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664
    226               :darwinx8632 :win64  :linuxx8632 :win32)
     227              :darwinx8632 :win64  :linuxx8632 :win32 :solarisx8632)
    227228             '(x86-error-signal x86-trap-support
    228229               x86-threads-utils x86-callback-support)))))
     
    438439    (:win64 "wx86-boot64.image")
    439440    (:linuxx8632 "x86-boot32")
    440     (:win32 "wx86-boot32.image")))
     441    (:win32 "wx86-boot32.image")
     442    (:solarisx8632 "sx86-boot32")))
    441443
    442444(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
     
    453455    (:win64 "wx86cl64.exe")
    454456    (:linuxx8632 "lx86cl")
    455     (:win32 "wx86cl.exe")))
     457    (:win32 "wx86cl.exe")
     458    (:solarisx8632 "sx86cl")))
    456459
    457460(defun standard-image-name (&optional (target (backend-name *host-backend*)))
     
    482485    (:win64 "win64")
    483486    (:linuxx8632 "linuxx8632")
    484     (:win32 "win32")))
     487    (:win32 "win32")
     488    (:solarisx8632 "solarisx86")))
    485489
    486490;;; If we distribute (e.g.) 32- and 64-bit versions for the same
  • branches/working-0711/ccl/lib/db-io.lisp

    r11164 r11267  
    577577   
    578578
    579 
     579(eval-when (:compile-toplevel :load-toplevel :execute)
    580580(defconstant db-string-constant 0)
    581581(defconstant db-read-string-constant 1)
     
    585585(defconstant db-double-constant 5)
    586586(defconstant db-char-constant 6)
     587(defconstant db-pointer-constant 7)
     588)
    587589
    588590(defparameter *arg-spec-encoding*
     
    693695                  (#.db-float-constant (pref dptr :dbm-constant.value.single-float))
    694696                  (#.db-double-constant (pref dptr :dbm-constant.value.double-float))
    695                   (#.db-char-constant (code-char (pref dptr :dbm-constant.value.u32)))))
     697                  (#.db-char-constant (code-char (pref dptr :dbm-constant.value.u32)))
     698                  (#.db-pointer-constant
     699                   (let* ((val (pref dptr :dbm-constant.value.u32)))
     700                     #+64-bit-target
     701                     (if (logbitp 31 val)
     702                       (setq val (logior val (ash #xffffffff 32))))
     703                     (%int-to-ptr val )))))
    696704          (cdb-free (pref datum :cdb-datum.data)))))
    697705    val))
     
    736744         short-float
    737745         double-float
    738          character)
     746         character
     747         macptr)
    739748     (rletZ ((constant :dbm-constant)
    740749             (content :cdb-datum)
     
    755764         (character
    756765          (setf (pref constant :dbm-constant.value.u32) (char-code val))
    757           (setf (pref constant :dbm-constant.class) db-char-constant)))
     766          (setf (pref constant :dbm-constant.class) db-char-constant))
     767         (macptr
     768          (setf (pref constant :dbm-constant.value.u32) (logand #xffffffff (%ptr-to-int val)))
     769          (setf (pref constant :dbm-constant.class) db-pointer-constant))
     770         )
    758771       (setf (pref content :cdb-datum.data) constant
    759772             (pref content :cdb-datum.size) (record-length :dbm-constant))
  • branches/working-0711/ccl/lib/foreign-types.lisp

    r11101 r11267  
    100100                        (:win64 "ccl:win64-headers;")
    101101                        (:linuxx8632 "ccl:x86-headers;")
    102                         (:win32 "ccl:win32-headers;"))
     102                        (:win32 "ccl:win32-headers;")
     103                        (:solarisx8632 "ccl:solarisx86-headers;"))
    103104                    :interface-package-name
    104105                    #.(ftd-interface-package-name *target-ftd*)
     
    15061507  (entry-name "" :type string)
    15071508  (arg-specs () :type list)
    1508   (result-spec nil :type symbol)
     1509  (result-spec nil :type (or symbol list))
    15091510  (min-args 0 :type fixnum))
    15101511
     
    19391940  ))
    19401941
    1941 
    1942 
    1943 
    1944 
    1945 
     1942(defmethod make-load-form ((p macptr) &optional env)
     1943  (declare (ignore env))
     1944  (let* ((value (%ptr-to-int p)))
     1945    (unless (or (< value 65536)
     1946                (>= value (- (ash 1 target::nbits-in-word) 65536)))
     1947      (error "~&~s can't be referenced as a constant because its address contains more than 16 significant bits." p))
     1948    (if (zerop value)
     1949      '+null-ptr+
     1950      `(%int-to-ptr ,value))))
     1951
     1952
     1953
     1954
  • branches/working-0711/ccl/lib/macros.lisp

    r11164 r11267  
    17041704
    17051705(defmacro with-filename-cstrs (&rest rest)
    1706   `(,(case (target-os-name)
    1707       (:darwin 'with-utf-8-cstrs)
    1708       (:windows 'with-native-utf-16-cstrs)
    1709       (t 'with-cstrs)) ,@rest))
     1706  (case (target-os-name)
     1707    (:darwin `(with-utf-8-cstrs ,@rest))
     1708    (:windows `(with-native-utf-16-cstrs ,@rest))
     1709    (t `(with-encoded-cstrs (pathname-encoding-name) ,@rest))))
    17101710
    17111711
     
    25362536         (result-type-spec :void)
    25372537         (args args)
     2538         (discard-stack-args nil)
    25382539         (woi nil)
    2539          (monitor nil)
    25402540         (need-struct-arg)
    25412541         (struct-return-arg-name)
     
    25522552        (if (eq (car args) :without-interrupts)
    25532553          (setq woi (cadr args) args (cddr args))
    2554           (if (eq (car args) :monitor-exception-ports)
    2555             (setq monitor (cadr args) args (cddr args))
    2556            
     2554          (if (eq (car args) :discard-stack-args)
     2555            (setq discard-stack-args t args (cdr args))
    25572556            (if (eq (car args) :error-return)
    25582557              (setq error-return
     
    25642563                  (arg-specs (pop args))
    25652564                  (arg-names (pop args))))))))
    2566       (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset)
     2565      (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset num-arg-bytes)
    25672566          (funcall (ftd-callback-bindings-function *target-ftd*)
    25682567                   stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name)
     2568        (unless num-arg-bytes (setq num-arg-bytes 0))
    25692569        (multiple-value-bind (body decls doc) (parse-body body env t)
    25702570          `(progn
     
    25942594                ,doc
    25952595              ,woi
    2596               ,monitor)))))))
     2596              ,(if discard-stack-args num-arg-bytes 0))))))))
    25972597
    25982598
  • branches/working-0711/ccl/lib/systems.lisp

    r11101 r11267  
    148148    (ffi-linuxx8632  "ccl:bin;ffi-linuxx8632" ("ccl:lib;ffi-linuxx8632.lisp"))
    149149    (ffi-win32 "ccl:bin;ffi-win32" ("ccl:lib;ffi-win32.lisp"))
     150    (ffi-solarisx8632 "ccl:bin;ffi-solarisx8632" ("ccl:lib;ffi-solarisx8632.lisp"))
    150151   
    151152    (db-io            "ccl:bin;db-io"            ("ccl:lib;db-io.lisp"))
  • branches/working-0711/ccl/library/leaks.lisp

    r10477 r11267  
    156156                     (and (consp key) (eq (car key) 'ccl::function-source-note))
    157157                     (typep key 'ccl::hash-table-vector)
    158                      (when (typep key 'ccl::symbol-vector)
    159                        (push (ccl::%symvector->symptr key) additions)
     158                     (when (and key
     159                                (typep key
     160                                  #+x8664-target 'ccl::symbol-vector
     161                                  #-x8664-target 'symbol
     162                                  ))
     163                       (push (ccl::symvector->symptr key) additions)
    160164                       t)
    161                      (when (typep key 'ccl::function-vector)
    162                        (push (ccl::%function-vector-to-function key) additions)
     165                     (when (typep key
     166                                  #+x8664-target 'ccl::function-vector
     167                                  #-x8664-target 'function
     168                                  )
     169                       (push (ccl::function-vector-to-function key) additions)
    163170                       t))
    164171              do
  • branches/working-0711/ccl/library/parse-ffi.lisp

    r11164 r11267  
    308308                  (c::\| (logior a b))
    309309                  (c::\& (logand a b))
    310                   (c::cast (if (foreign-typep b a)
     310                  (c::cast (if (foreign-typep (setq b (eval-parsed-c-expression b constant-alist)) a)
    311311                             b
    312312                             (if (and (typep a 'foreign-integer-type)
     
    315315                                      (not (> (integer-length b)
    316316                                              (foreign-integer-type-bits a))))
    317                                (logand b (1- (ash 1 (foreign-integer-type-bits a)))))))
     317                               (logand b (1- (ash 1 (foreign-integer-type-bits a))))
     318                               (if (and (typep a 'foreign-pointer-type)
     319                                        (typep b 'integer)
     320                                        (<= (integer-length b) 16))
     321                                 (progn                                   
     322                                   (%int-to-ptr (logand b #xffffffff)))))))
     323                               
    318324                                           
    319325                  (t
     
    331337      (progn
    332338        (unless (ffi-macro-tokens macro)
    333           (multiple-value-bind (tokens error) (ignore-errors (string-to-tokens string))
    334             (if error
    335               (setf (ffi-macro-disposition macro) :bad-tokenize)
    336               (setf (ffi-macro-tokens macro) tokens))))
     339          (let* ((transitive (gethash (ffi-macro-expansion macro) macro-table)))
     340            (if transitive
     341              (setf (ffi-macro-tokens macro) transitive
     342                    (gethash (ffi-macro-name macro) macro-table) transitive)
     343              (multiple-value-bind (tokens error) (ignore-errors (string-to-tokens string))
     344                (if error
     345                  (setf (ffi-macro-disposition macro) :bad-tokenize)
     346                  (setf (ffi-macro-tokens macro) tokens))))))
    337347        (unless (ffi-macro-expression macro)
    338348          (let* ((tokens (ffi-macro-tokens macro)))
  • branches/working-0711/ccl/lisp-kernel/Threads.h

    r10944 r11267  
    3434#include <sys/syscall.h>
    3535#include <sys/lwp.h>
     36#endif
     37
     38#ifdef LINUX
     39#include <sys/syscall.h>
    3640#endif
    3741
  • branches/working-0711/ccl/lisp-kernel/area.h

    r11089 r11267  
    167167#endif
    168168#ifdef SOLARIS
     169#ifdef X8664
    169170#define IMAGE_BASE_ADDRESS 0x300000000000L
     171#else
     172#define IMAGE_BASE_ADDRESS 0x10000000
     173#endif
    170174#endif
    171175#ifdef DARWIN
  • branches/working-0711/ccl/lisp-kernel/gc-common.c

    r10944 r11267  
    11061106    GCDebug = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_integrity_check_bit) != 0);
    11071107    if (GCDebug) {
    1108       check_all_areas();
     1108      check_all_areas(tcr);
    11091109    }
    11101110  }
     
    13581358
    13591359  if (GCDebug) {
    1360     check_all_areas();
     1360    check_all_areas(tcr);
    13611361  }
    13621362
  • branches/working-0711/ccl/lisp-kernel/gc.h

    r10944 r11267  
    210210LispObj locative_forwarding_address(LispObj);
    211211void check_refmap_consistency(LispObj *, LispObj *, bitvector);
    212 void check_all_areas(void);
     212void check_all_areas(TCR *);
    213213void mark_tstack_area(area *);
    214214void mark_vstack_area(area *);
  • branches/working-0711/ccl/lisp-kernel/image.c

    r10944 r11267  
    331331      subtag = header_subtag(x1);
    332332      if (subtag == subtag_macptr) {
    333         if (start[1]) {
    334           /* Leave NULL pointers alone */
     333        if ((start[1] >= (natural)0x10000) && (start[1] < (natural)-0x10000)) {
     334          /* Leave small pointers alone */
    335335          *start = make_header(subtag_dead_macptr,header_element_count(x1));
    336336        }
  • branches/working-0711/ccl/lisp-kernel/lisp-debug.c

    r11089 r11267  
    170170                     "ecx", "eax", "???", "???", "eip",
    171171                     "???", "efl", "esp"};
     172#endif
     173#ifdef SOLARIS
     174char *Iregnames[] = {"???", "???", "???", "???", "???",
     175                     "edi", "esi", "ebp", "???", "ebx",
     176                     "edx", "ecx", "eax", "???", "???",
     177                     "eip", "???", "efl", "esp"};
    172178#endif
    173179#endif
  • branches/working-0711/ccl/lisp-kernel/pmcl-kernel.c

    r11164 r11267  
    407407#endif
    408408#ifdef FREEBSD
     409#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
     410#endif
     411#ifdef SOLARIS
    409412#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
    410413#endif
     
    15471550#endif
    15481551
     1552#ifdef SOLARIS
     1553#ifdef X8632
     1554  {
     1555    extern void solaris_ldt_init(void);
     1556    solaris_ldt_init();
     1557  }
     1558#endif
     1559#endif
     1560
    15491561#ifndef WINDOWS
    15501562  main_thread_pid = getpid();
  • branches/working-0711/ccl/lisp-kernel/ppc-gc.c

    r10944 r11267  
    155155
    156156void
    157 check_all_areas()
     157check_all_areas(TCR *tcr)
    158158{
    159159  area *a = active_dynamic_area;
  • branches/working-0711/ccl/lisp-kernel/thread_manager.c

    r11164 r11267  
    11411141}
    11421142#endif
     1143#ifdef SOLARIS
     1144#include <sys/sysi86.h>
     1145
     1146bitvector ldt_entries_in_use = NULL;
     1147pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER;  /* simple, non-recursive mutex */
     1148
     1149void
     1150solaris_ldt_init()
     1151{
     1152  int fd;
     1153  struct ssd s;
     1154
     1155  ldt_entries_in_use=malloc(8192/8);
     1156  zero_bits(ldt_entries_in_use,8192);
     1157 
     1158  fd = open("/proc/self/ldt", O_RDONLY);
     1159
     1160  while(read(fd,&s,sizeof(s)) == sizeof(s)) {
     1161    set_bit(ldt_entries_in_use,s.sel>>3);
     1162  }
     1163  close(fd);
     1164}
     1165   
     1166
     1167void
     1168setup_tcr_extra_segment(TCR *tcr)
     1169{
     1170  struct ssd s;
     1171  int i;
     1172
     1173  pthread_mutex_lock(&ldt_lock);
     1174
     1175  for (i = 0; i < 8192; i++) {
     1176    if (!ref_bit(ldt_entries_in_use,i)) {
     1177      s.sel = (i<<3)|7;
     1178      s.bo = (unsigned int)tcr;
     1179      s.ls = sizeof(TCR);
     1180      s.acc1 = 0xf2;
     1181      s.acc2 = 4;
     1182
     1183      if (sysi86(SI86DSCR, &s) >= 0) {
     1184        set_bit(ldt_entries_in_use,i);
     1185        tcr->ldt_selector = (i<<3)|7;
     1186        pthread_mutex_unlock(&ldt_lock);
     1187        return;
     1188      }
     1189      set_bit(ldt_entries_in_use,i);
     1190    }
     1191  }
     1192  pthread_mutex_unlock(&ldt_lock);
     1193  fprintf(stderr, "All 8192 LDT descriptors in use\n");
     1194  _exit(1);
     1195
     1196
     1197 
     1198}
     1199
     1200void
     1201free_tcr_extra_segment(TCR *tcr)
     1202{
     1203  struct ssd s;
     1204  int i;
     1205
     1206  pthread_mutex_lock(&ldt_lock);
     1207  __asm__ volatile ("mov %0,%%fs" : : "r"(0));
     1208  s.sel = tcr->ldt_selector;
     1209  i = s.sel>>3;
     1210  tcr->ldt_selector = 0;
     1211  s.bo = 0;
     1212  s.ls = 0;
     1213  s.acc1 = 0;
     1214  s.acc2 = 0;
     1215  sysi86(SI86DSCR, &s);
     1216  clr_bit(ldt_entries_in_use,i);
     1217  pthread_mutex_unlock(&ldt_lock);
     1218}
     1219
     1220#endif
    11431221#endif
    11441222
     
    12191297#ifndef WINDOWS
    12201298  tcr->shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS;
     1299#else
     1300  tcr->shutdown_count = 1;
    12211301#endif
    12221302  return tcr;
     
    12261306shutdown_thread_tcr(void *arg)
    12271307{
    1228   TCR *tcr = TCR_FROM_TSD(arg);
     1308  TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0);
    12291309
    12301310  area *vs, *ts, *cs;
    12311311  void *termination_semaphore;
    12321312 
     1313  if (current == NULL) {
     1314    current = tcr;
     1315  }
     1316
    12331317  if (--(tcr->shutdown_count) == 0) {
    12341318    if (tcr->flags & (1<<TCR_FLAG_BIT_FOREIGN)) {
     
    12431327    darwin_exception_cleanup(tcr);
    12441328#endif
    1245     LOCK(lisp_global(TCR_AREA_LOCK),tcr);
     1329    LOCK(lisp_global(TCR_AREA_LOCK),current);
    12461330    vs = tcr->vs_area;
    12471331    tcr->vs_area = NULL;
     
    12791363    CloseHandle((HANDLE)tcr->io_datum);
    12801364    tcr->io_datum = NULL;
    1281 #endif
    1282     UNLOCK(lisp_global(TCR_AREA_LOCK),tcr);
     1365    free(tcr->native_thread_info);
     1366    tcr->native_thread_info = NULL;
     1367#endif
     1368    UNLOCK(lisp_global(TCR_AREA_LOCK),current);
    12831369    if (termination_semaphore) {
    12841370      SEM_RAISE(termination_semaphore);
     
    13181404  return ((void *) (natural)
    13191405#ifdef LINUX
     1406#ifdef __NR_gettid
     1407          syscall(__NR_gettid)
     1408#else
    13201409          getpid()
     1410#endif
    13211411#endif
    13221412#ifdef DARWIN
     
    13711461#ifdef WINDOWS
    13721462  tcr->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL);
     1463  tcr->native_thread_info = malloc(sizeof(CONTEXT));
    13731464#endif
    13741465  tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM));
     
    17251816  DWORD rc;
    17261817  if (suspend_count == 1) {
    1727     /* Can't seem to get gcc to align a CONTEXT structure correctly */
    1728     char _contextbuf[sizeof(CONTEXT)+__alignof(CONTEXT)];
    1729 
    1730     CONTEXT *suspend_context, *pcontext;
     1818    CONTEXT  *pcontext = (CONTEXT *)tcr->native_thread_info;
    17311819    HANDLE hthread = (HANDLE)(tcr->osid);
    17321820    pc where;
     
    17341822    LispObj foreign_rsp;
    17351823
    1736     pcontext = (CONTEXT *)((((natural)&_contextbuf)+15)&~15);
    1737 
     1824    if (hthread == NULL) {
     1825      return false;
     1826    }
    17381827    rc = SuspendThread(hthread);
    17391828    if (rc == -1) {
     
    17841873      } else {
    17851874        area *ts = tcr->ts_area;
    1786         /* If we're in the lisp heap, or in x86-spentry64.o, or in
    1787            x86-subprims64.o, or in the subprims jump table at #x15000,
     1875        /* If we're in the lisp heap, or in x86-spentry??.o, or in
     1876           x86-subprims??.o, or in the subprims jump table at #x15000,
    17881877           or on the tstack ... we're just executing lisp code.  Otherwise,
    17891878           we got an exception while executing lisp code, but haven't
     
    18211910    } else {
    18221911      if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) {
     1912        if (!tcr->pending_exception_context) {
     1913          FBug(pcontext, "we're confused here.");
     1914        }
    18231915        *pcontext = *tcr->pending_exception_context;
    18241916        tcr->pending_exception_context = NULL;
     
    18261918      }
    18271919    }
    1828 
    1829     /* If the context's stack pointer is pointing into the cs_area,
    1830        copy the context below the stack pointer. else copy it
    1831        below tcr->foreign_rsp. */
    1832     foreign_rsp = xpGPR(pcontext,Isp);
    1833 
    1834     if ((foreign_rsp < (LispObj)(cs->low)) ||
    1835         (foreign_rsp >= (LispObj)(cs->high))) {
    1836       foreign_rsp = (LispObj)(tcr->foreign_sp);
    1837     }
    1838     foreign_rsp -= 0x200;
    1839     foreign_rsp &= ~15;
    1840     suspend_context = (CONTEXT *)(foreign_rsp)-1;
    1841     *suspend_context = *pcontext;
    1842     tcr->suspend_context = suspend_context;
     1920    tcr->suspend_context = pcontext;
    18431921    return true;
    18441922  }
     
    19081986         mark the TCR as dead and kill thw Windows thread. */
    19091987      tcr->osid = 0;
    1910       if (!TerminateThread(osid, 0)) {
     1988      if (!TerminateThread((HANDLE)osid, 0)) {
    19111989        result = false;
     1990      } else {
     1991        shutdown_thread_tcr(tcr);
    19121992      }
    19131993#else
     
    19482028
    19492029    if (context) {
     2030      context->ContextFlags = CONTEXT_ALL;
    19502031      tcr->suspend_context = NULL;
    19512032      SetThreadContext(hthread,context);
  • branches/working-0711/ccl/lisp-kernel/windows-calls.c

    r11164 r11267  
    365365
    366366  hevent = (HANDLE)tcr->io_datum;
     367  if (hfile == (HANDLE)1) {
     368    hfile = GetStdHandle(STD_OUTPUT_HANDLE);
     369  } else if (hfile == (HANDLE) 2) {
     370    hfile = GetStdHandle(STD_ERROR_HANDLE);
     371  }
    367372
    368373
  • branches/working-0711/ccl/lisp-kernel/x86-asmutils32.s

    r11164 r11267  
    135135_endfn
    136136
    137 /* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2, arg_3)  */
     137/* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2)  */
    138138/*   Not fully general, but should get us off of the signal stack */
    139139/* Beware: on Darwin, GDB can get very confused by this code, and
    140140   doesn't really get unconfused until the target function - the
    141    handler - has built its stack frame */
    142 /* The lone caller of this function actually doesn't pass arg_3.
     141   handler - has built its stack frame
     142   The lone caller of this function passes 3 arguments (besides
     143   the new stack pointer and the handler address.)
    143144   On platforms where the C stack must be 16-byte aligned, pushing
    144    4 words (arg_0-arg_3) helps make it aligned before the return
     145   a 4th word helps make the stack aligned before the return
    145146   address is (re-)pushed.
    146147   On Linux, there are severe constraints on what the top of stack
    147148   can look like when rt_sigreturn (the code at the return address)
    148149   runs, and there aren't any constraints on stack alignment, so
    149    we don't push "arg_3" on the new stack.*/
     150   we don't push the extra word on the new stack.*/
    150151_exportfn(C(switch_to_foreign_stack))
    151152        __(addl $4,%esp)        /* discard return address, on wrong stack */
     
    155156        __(pop %ebx)            /* arg_1 */
    156157        __(pop %ecx)            /* arg_2 */
    157         __ifndef([LINUX])       
    158         __(pop %edx)            /* arg_3 */
    159         __endif
    160158        __(mov %edi,%esp)
    161159        __(pop %edi)            /* Return address pushed by caller */
    162160        __ifndef([LINUX])
    163         __(push %edx)
    164         __endif
    165         __(push %ecx)
    166         __(push %ebx)
    167         __(push %eax)
    168         __(push %edi)           /* On some platforms, we don't really return */
    169         __(jmp *%esi)
     161        __(push $0)             /* For alignment. See comment above */
     162        __endif
     163        __(push %ecx)           /* arg_2 */
     164        __(push %ebx)           /* arg_1 */
     165        __(push %eax)           /* arg_0 */
     166        __(push %edi)           /* return address */
     167        __(jmp *%esi)           /* On some platforms, we don't really return */
    170168_endfn
    171169
  • branches/working-0711/ccl/lisp-kernel/x86-asmutils64.s

    r11089 r11267  
    152152/* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2, arg_3)  */
    153153/*   Not fully general, but should get us off of the signal stack */
     154        __ifndef([WINDOWS])
    154155_exportfn(C(switch_to_foreign_stack))
    155         __ifdef([WINDOWS])
    156         __(movq 8(%rsp), %ctemp0)
    157         __(movq 16(%rsp), %ctemp1)
    158         __endif
    159         __(movq %carg0,%rsp)
    160         __(movq %carg1,%rax)
    161         __(movq %carg2,%carg0)
    162         __(movq %carg3,%carg1)
    163         __ifdef([WINDOWS])
    164         __(movq %ctemp0, %carg2)
    165         __(movq %ctemp1, %carg3)
    166         __else
    167         __(movq %carg4,%carg2)
    168         __(movq %carg5,%carg3)
    169         __endif
     156        __(movq %rdi,%rsp)
     157        __(movq %rsi,%rax)
     158        __(movq %rdx,%rdi)
     159        __(movq %rcx,%rsi)
     160        __(movq %r8,%rdx)
     161        __(movq %r9,%rcx)
    170162        __(jmp *%rax)
    171163_endfn
    172 
     164        __endif
     165       
    173166_exportfn(C(freebsd_sigreturn))
    174167        __(movl $417,%eax)      /* SYS_sigreturn */
  • branches/working-0711/ccl/lisp-kernel/x86-constants32.h

    r11164 r11267  
    3939#define REG_EFL 17
    4040#define REG_ESP 19
     41#endif
     42
     43#ifdef SOLARIS
     44#include <sys/regset.h>
     45#include <limits.h>
     46#define REG_EAX EAX
     47#define REG_EBX EBX
     48#define REG_ECX ECX
     49#define REG_EDX EDX
     50#define REG_ESI ESI
     51#define REG_EDI EDI
     52#define REG_EBP EBP
     53#define REG_ESP UESP    /* Maybe ... ESP is often 0, but who knows why ? */
     54#define REG_EFL EFL
     55#define REG_EIP EIP
    4156#endif
    4257
  • branches/working-0711/ccl/lisp-kernel/x86-constants64.h

    r11164 r11267  
    7777#define REG_RIP     16
    7878#endif
     79
    7980/* Define indices of the GPRs in the mcontext component of a ucontext */
    8081#define Itemp0      REG_RBX
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.c

    r11164 r11267  
    12291229
    12301230void
    1231 signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context, TCR *tcr, int old_valence)
     1231signal_handler(int signum, siginfo_t *info, ExceptionInformation  *context
     1232#ifdef DARWIN
     1233               , TCR *tcr, int old_valence
     1234#endif
     1235)
    12321236{
    12331237#ifdef DARWIN_GS_HACK
     
    12361240  xframe_list xframe_link;
    12371241#ifndef DARWIN
    1238   tcr = get_tcr(false);
    1239 
    1240   old_valence = prepare_to_wait_for_exception_lock(tcr, context);
     1242  TCR *tcr = get_tcr(false);
     1243
     1244  int old_valence = prepare_to_wait_for_exception_lock(tcr, context);
    12411245#endif
    12421246  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
     
    19821986#endif
    19831987
    1984 #ifdef WINDOWS
    1985 void
    1986 quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
    1987 {
    1988 }
    1989 #else
    1990 void
    1991 quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
    1992 {
    1993 #ifdef DARWIN_GS_HACK
    1994   Boolean gs_was_tcr = ensure_gs_pthread();
    1995 #endif
    1996   TCR *tcr = get_tcr(false);
    1997   area *a;
    1998   sigset_t mask;
    1999  
    2000   sigemptyset(&mask);
    2001 
    2002 
     1988
     1989/* This should only be called when the tcr_area_lock is held */
     1990void
     1991empty_tcr_stacks(TCR *tcr)
     1992{
    20031993  if (tcr) {
     1994    area *a;
     1995
    20041996    tcr->valence = TCR_STATE_FOREIGN;
    20051997    a = tcr->vs_area;
     
    20162008    }
    20172009  }
     2010}
     2011
     2012#ifdef WINDOWS
     2013void
     2014quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
     2015{
     2016}
     2017#else
     2018void
     2019quit_handler(int signum, siginfo_t *info, ExceptionInformation *xp)
     2020{
     2021#ifdef DARWIN_GS_HACK
     2022  Boolean gs_was_tcr = ensure_gs_pthread();
     2023#endif
     2024  TCR *tcr = get_tcr(false);
     2025  sigset_t mask;
     2026 
     2027  sigemptyset(&mask);
     2028
     2029  empty_tcr_stacks(tcr);
    20182030 
    20192031  pthread_sigmask(SIG_SETMASK,&mask,NULL);
     
    22912303  if (allocptr_tag != 0) {
    22922304    alloc_instruction_id state = recognize_alloc_instruction(program_counter);
    2293 #ifdef X8664
    22942305    signed_natural
    22952306      disp = (allocptr_tag == fulltag_cons) ?
    22962307      sizeof(cons) - fulltag_cons :
     2308#ifdef X8664
    22972309      xpGPR(xp,Iimm1);
    22982310#else
    2299       signed_natural disp = (allocptr_tag == fulltag_cons) ?
    2300       sizeof(cons) - fulltag_cons :
    2301       xpMMXreg(xp,Imm0);
     2311      xpGPR(xp,Iimm0);
    23022312#endif
    23032313    LispObj new_vector;
  • branches/working-0711/ccl/lisp-kernel/x86-exceptions.h

    r11164 r11267  
    7373
    7474#ifdef SOLARIS
    75 #ifdef X8664
    7675#define xpGPRvector(x) ((x)->uc_mcontext.gregs)
    7776#define xpGPR(x,gprno) (xpGPRvector(x)[gprno])
     
    8079#define eflags_register(xp) xpGPR(xp,Iflags)
    8180#define xpXMMregs(x)(&((x)->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm[0]))
     81#ifdef X8632
     82#define xpMMXreg(x,n)*(natural *)(&(((struct fnsave_state *)(&(((x)->uc_mcontext.fpregs))))->f_st[n]))
    8283#endif
    8384#endif
     
    182183#ifdef SOLARIS
    183184#define SIGNUM_FOR_INTN_TRAP SIGSEGV
     185#ifdef X8664
    184186#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2))
     187#else
     188#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,TRAPNO)==0xd)&&((xpGPR(xp,ERR)&7)==2))
     189#endif
    185190#define SIGRETURN(context) setcontext(context)
    186191#endif
  • branches/working-0711/ccl/lisp-kernel/x86-gc.c

    r11089 r11267  
    221221}
    222222
    223 void
    224 check_all_areas()
     223#ifdef X8632
     224void
     225check_xp(ExceptionInformation *xp, natural node_regs_mask)
     226{
     227  natural *regs = (natural *) xpGPRvector(xp), dnode;
     228
     229  if (node_regs_mask & (1<<0)) check_node(regs[REG_EAX]);
     230  if (node_regs_mask & (1<<1)) check_node(regs[REG_ECX]);
     231  if (regs[REG_EFL] & EFL_DF) {
     232    /* DF set means EDX should be treated as an imm reg */
     233    ;
     234  } else
     235    if (node_regs_mask & (1<<2)) check_node(regs[REG_EDX]);
     236
     237  if (node_regs_mask & (1<<3)) check_node(regs[REG_EBX]);
     238  if (node_regs_mask & (1<<4)) check_node(regs[REG_ESP]);
     239  if (node_regs_mask & (1<<5)) check_node(regs[REG_EBP]);
     240  if (node_regs_mask & (1<<6)) check_node(regs[REG_ESI]);
     241  if (node_regs_mask & (1<<7)) check_node(regs[REG_EDI]);
     242}
     243#else
     244void
     245check_xp(ExceptionInformation *xp)
     246{
     247  natural *regs = (natural *) xpGPRvector(xp), dnode;
     248
     249  check_node(regs[Iarg_z]);
     250  check_node(regs[Iarg_y]);
     251  check_node(regs[Iarg_x]);
     252  check_node(regs[Isave3]);
     253  check_node(regs[Isave2]);
     254  check_node(regs[Isave1]);
     255  check_node(regs[Isave0]);
     256  check_node(regs[Ifn]);
     257  check_node(regs[Itemp0]);
     258  check_node(regs[Itemp1]);
     259  check_node(regs[Itemp2]);
     260}
     261#endif
     262
     263void
     264check_tcrs(TCR *first)
     265{
     266  xframe_list *xframes;
     267  ExceptionInformation *xp;
     268 
     269  TCR *tcr = first;
     270  LispObj *tlb_start,*tlb_end;
     271
     272  do {
     273    xp = tcr->gc_context;
     274    if (xp) {
     275#ifdef X8632
     276      check_xp(xp,tcr->node_regs_mask);
     277#else
     278      check_xp(xp);
     279#endif
     280    }
     281#ifdef X8632
     282    check_node(tcr->save0);
     283    check_node(tcr->save1);
     284    check_node(tcr->save2);
     285    check_node(tcr->save3);
     286    check_node(tcr->next_method_context);
     287#endif
     288    for (xframes = (xframe_list *) tcr->xframe;
     289         xframes;
     290         xframes = xframes->prev) {
     291#ifndef X8632
     292      check_xp(xframes->curr);
     293#else
     294      check_xp(xframes->curr, xframes->node_regs_mask);
     295#endif
     296    }
     297    tlb_start = tcr->tlb_pointer;
     298    if (tlb_start) {
     299      tlb_end = tlb_start + ((tcr->tlb_limit)>>fixnumshift);
     300      check_range(tlb_start,tlb_end,false);
     301    }
     302    tcr = tcr->next;
     303  } while (tcr != first);
     304}
     305
     306 
     307void
     308check_all_areas(TCR *tcr)
    225309{
    226310  area *a = active_dynamic_area;
     
    267351    code = (a->code);
    268352  }
     353
     354  check_tcrs(tcr);
    269355}
    270356
  • branches/working-0711/ccl/lisp-kernel/x86-spentry32.s

    r11164 r11267  
    4444        __(andb $tagmask,%imm0_b)
    4545        __(cmpb $tag_misc,%imm0_b)
    46         __(je 0f)
    47         __(uuo_error_reg_not_tag(Rarg_y,tag_misc))
    48 0:      __(testb $fixnummask,%arg_z_b)
    49         __(je 1f)
    50         __(uuo_error_reg_not_fixnum(Rarg_z))
    51 1:      __(movl misc_header_offset(%arg_y),%imm0)
     46        __(jne 0f)
     47        __(testb $fixnummask,%arg_z_b)
     48        __(jne 1f)
     49        __(movl misc_header_offset(%arg_y),%imm0)
    5250        __(xorb %imm0_b,%imm0_b)
    5351        __(shrl $num_subtag_bits-fixnumshift,%imm0)
    5452        __(cmpl %imm0,%arg_z)
    55         __(jb 2f)
    56         __(uuo_error_vector_bounds(Rarg_z,Rarg_y))
    57 2:      __(xorl %imm0,%imm0)
     53        __(jae 2f)
    5854        __(movb misc_subtag_offset(%arg_y),%imm0_b)
    59         /* fall through */
     55        __(jmp C(misc_ref_common))
     56
     570:      __(uuo_error_reg_not_tag(Rarg_y,tag_misc))
     581:      __(uuo_error_reg_not_fixnum(Rarg_z))
     592:      __(uuo_error_vector_bounds(Rarg_z,Rarg_y))
    6060_endsubp(misc_ref)
    6161
     
    426426        __(and $tagmask,%imm0)
    427427        __(cmp $tag_misc,%imm0)
    428         __(je 0f)
    429         __(uuo_error_reg_not_tag(Rarg_y,tag_misc))
    430 0:      __(testb $fixnummask,%arg_z_b)
    431         __(je 1f)
    432         __(uuo_error_reg_not_fixnum(Rarg_z))
    433 1:      __(movl misc_header_offset(%arg_y),%imm0)
     428        __(jne 0f)
     429        __(testb $fixnummask,%arg_z_b)
     430        __(jne 1f)
     431        __(movl misc_header_offset(%arg_y),%imm0)
    434432        __(xorb %imm0_b,%imm0_b)
    435433        __(shrl $num_subtag_bits-fixnumshift,%imm0)
    436434        __(cmp %imm0,%arg_z)
    437         __(jb 2f)
    438         __(uuo_error_vector_bounds(Rarg_z,Rarg_y))
    439 2:      __(unbox_fixnum(%temp0,%imm0))
     435        __(jae 2f)
     436        __(unbox_fixnum(%temp0,%imm0))
    440437        __(jmp C(misc_ref_common))
     4380:      __(uuo_error_reg_not_tag(Rarg_y,tag_misc))
     4391:      __(uuo_error_reg_not_fixnum(Rarg_z))
     4402:      __(uuo_error_vector_bounds(Rarg_z,Rarg_y))
    441441_endsubp(subtag_misc_ref)
    442442
     
    446446        __(andb $tagmask,%imm0_b)
    447447        __(cmpb $tag_misc,%imm0_b)
    448         __(je 0f)
    449         __(uuo_error_reg_not_tag(Rtemp0,tag_misc))
    450 0:      __(mov %arg_y,%imm0)
     448        __(jne 0f)
     449        __(mov %arg_y,%imm0)
    451450        __(testb $fixnummask,%imm0_b)
    452         __(je 1f)
    453         __(uuo_error_reg_not_fixnum(Rarg_y))
    454 1:      __(movl misc_header_offset(%temp0),%imm0)
     451        __(jne 1f)
     452        __(movl misc_header_offset(%temp0),%imm0)
    455453        __(xorb %imm0_b,%imm0_b)
    456454        __(shrl $num_subtag_bits-fixnumshift,%imm0)
    457455        __(cmpl %imm0,%arg_y)
    458         __(jb 2f)
    459         __(uuo_error_vector_bounds(Rarg_y,Rtemp0))
    460 2:      __(unbox_fixnum(%temp1,%imm0))
     456        __(jae 2f)
     457        __(unbox_fixnum(%temp1,%imm0))
    461458        __(jmp C(misc_set_common))
     4590:      __(uuo_error_reg_not_tag(Rtemp0,tag_misc))
     4601:      __(uuo_error_reg_not_fixnum(Rarg_y))
     4612:      __(uuo_error_vector_bounds(Rarg_y,Rtemp0))
    462462_endsubp(subtag_misc_set)
    463463
     
    467467        __(andb $tagmask,%imm0_b)
    468468        __(cmpb $tag_misc,%imm0_b)
    469         __(je 0f)
    470         __(uuo_error_reg_not_tag(Rtemp0,tag_misc))
    471 0:      __(mov %arg_y,%imm0)    /* no byte reg for %arg_y/%esi */
    472         __(testb $fixnummask,%imm0_b)
    473         __(je 1f)
    474         __(uuo_error_reg_not_fixnum(Rarg_y))
    475 1:      __(movl misc_header_offset(%temp0),%imm0)
     469        __(jne 0f)
     470        __(test $fixnummask,%arg_y)
     471        __(jne 1f)
     472        __(movl misc_header_offset(%temp0),%imm0)
    476473        __(xorb %imm0_b,%imm0_b)
    477474        __(shrl $num_subtag_bits-fixnumshift,%imm0)
    478475        __(cmpl %imm0,%arg_y)
    479         __(jb 2f)
    480         __(uuo_error_vector_bounds(Rarg_y,Rtemp0))
    481 2:      __(xorl %imm0,%imm0)
     476        __(jae 2f)
     477        __(xorl %imm0,%imm0)
    482478        __(movb misc_subtag_offset(%temp0),%imm0_b)
    483         /* fall through */
     479        __(jmp C(misc_set_common))
     4800:      __(uuo_error_reg_not_tag(Rtemp0,tag_misc))
     4811:      __(uuo_error_reg_not_fixnum(Rarg_y))
     4822:      __(uuo_error_vector_bounds(Rarg_y,Rtemp0))
    484483_endsubp(misc_set)
    485484
     
    34433442        __(movl (%temp1,%imm0),%arg_z)
    34443443        __(cmpb $no_thread_local_binding_marker,%arg_z_b)
    3445         __(jne 8f)
     3444        __(cmovel symbol.vcell(%arg_y),%arg_z)
     3445        __(cmpb $unbound_marker,%arg_z_b)
     3446        __(je 9f)
     34478:      __(repret)
    344634487:      __(movl symbol.vcell(%arg_y),%arg_z)
    3447 8:      __(cmpb $unbound_marker,%arg_z_b)
    3448         __(jne 9f)
    3449         __(uuo_error_reg_unbound(Rarg_y))
    3450 9:      __(repret)
     3449        __(cmpb $unbound_marker,symbol.vcell(%arg_y))
     3450        __(je 9f)
     3451        __(repret)
     34529:      __(uuo_error_reg_unbound(Rarg_y))
    34513453_endsubp(specrefcheck)
    34523454
     
    38913893        __(andb $fulltagmask,%imm0_b)
    38923894        __(cmpb $fulltag_cons,%imm0_b)
    3893         __(je 2f)
    3894         __(uuo_error_reg_not_list(Rarg_z))
    3895 2:      __(_car(%arg_z,%temp0))
     3895        __(jne 2f)
     3896        __(_car(%arg_z,%temp0))
    38963897        __(_cdr(%arg_z,%arg_z))
    38973898        __(cmpl $nil_value,%temp0)
     
    39003901        __(andb $fulltagmask,%imm0_b)
    39013902        __(cmpb $fulltag_cons,%imm0_b)
    3902         __(je 3f)
    3903         __(uuo_error_reg_not_list(Rtemp0))
    3904 3:      __(_car(%temp0,%temp1))
     3903        __(jne 3f)
     3904        __(_car(%temp0,%temp1))
    39053905        __(cmpl %temp1,%arg_y)
    39063906        __(jne 4f)
     
    391039105:      __(jnz 1b)
    39113911        __(repret)
     39122:      __(uuo_error_reg_not_list(Rarg_z))
     39133:      __(uuo_error_reg_not_list(Rtemp0))
    39123914_endsubp(builtin_assq)
    39133915
     
    39183920        __(andb %arg_z_b,%imm0_b)
    39193921        __(cmpb $fulltag_cons,%imm0_b)
    3920         __(jz 2f)
    3921         __(uuo_error_reg_not_list(Rarg_z))
    3922 2:      __(_car(%arg_z,%temp1))
     3922        __(jne 2f)
     3923        __(_car(%arg_z,%temp1))
    39233924        __(_cdr(%arg_z,%temp0))
    39243925        __(cmpl %temp1,%arg_y)
     
    392839293:      __(jnz 1b)
    392939304:      __(repret)
     39312:      __(uuo_error_reg_not_list(Rarg_z))
    39303932_endsubp(builtin_memq)
    39313933
     
    40894091        __(push %ebp)
    40904092        __(mov %esp,%ebp)
    4091         __(push %temp0)
    4092         __(push %temp1)
    4093         __(push %arg_y)
    4094         __(push %arg_z)
    4095         __(push %fn)
     4093        __(push %temp0)                 
     4094        __(push %temp1)                 
     4095        __(push %arg_y)                 
     4096        __(push %arg_z)                 
     4097        __(push %fn)         
    40964098        __ifdef([WIN32_ES_HACK])
    40974099         __(movl rcontext(tcr.linear),%ebx)
     
    41464148        __(movl rcontext(tcr.save_ebp),%ebp)
    41474149        __(movl $TCR_STATE_LISP,rcontext(tcr.valence))
    4148         __(pop %fn)
    4149         __(pop %arg_z)
    4150         __(pop %arg_y)
    4151         __(pop %temp1)
    4152         __(ldmxcsr rcontext(tcr.lisp_mxcsr))
     4150        __(pop %fn)             
     4151        __(pop %arg_z)           
     4152        __(pop %arg_y)           
     4153        __(pop %temp1)
     4154        __(ldmxcsr rcontext(tcr.lisp_mxcsr))
    41534155        __(check_pending_interrupt(%temp0))
    4154         __(pop %temp0)
     4156        __(pop %temp0)
    41554157        __(leave)
    41564158        __(ret)
     
    42304232        __(subl $24,%esp)
    42314233        __(movl $0,-16(%ebp)) /* No FP result */
     4234        __(movl %eax,%ecx)    /* extract args-discard count */
     4235        __(shrl $24,%ecx)
     4236        __(andl $0x00ffffff,%eax)
     4237        __(movl %ecx,-12(%ebp))
    42324238        /* If the C stack is 16-byte aligned by convention,
    42334239           it should still be, and this'll be a NOP. */
     
    42384244        __(push %ebx)
    42394245        __(push %ebp)
    4240        
    42414246        __(box_fixnum(%eax,%esi))       /* put callback index in arg_y */
    42424247        __(ref_global(get_tcr,%eax))
    4243         __(push $1)
     4248        __(subl $12,%esp)               /* alignment */
     4249        __(push $1)                     /* stack now 16-byte aligned */
    42444250        __(call *%eax)
    4245         __(addl $node_size,%esp)
     4251        __(addl $16,%esp)               /* discard arg, alignment words */
    42464252        /* linear TCR addr now in %eax */
    42474253        __(movw tcr.ldt_selector(%eax), %rcontext_reg)
     
    42914297        __(pop %edi)
    42924298        __(cmpb $1,-16(%ebp))
    4293         __(movl -12(%ebp),%ecx) /* magic value for ObjC bridge */
     4299        __(movl -12(%ebp),%ecx) /* magic value for ObjC bridge or winapi */
    42944300        __(jae 1f)
    42954301        __(movl -8(%ebp),%eax)
    42964302        __(movl -4(%ebp),%edx)
    42974303        __(leave)
    4298         __(ret)
     4304        __ifdef([WIN_32])
     4305         __(testl %ecx,%ecx)
     4306         __(jne local_label(winapi_return))
     4307         __(repret)
     4308        __else
     4309         __(ret)
     4310        __endif
    429943111:      __(jne 2f)
    43004312        /* single float return in x87 */
    43014313        __(flds -8(%ebp))
    43024314        __(leave)
    4303         __(ret)
     4315        __ifdef([WIN_32])
     4316         __(testl %ecx,%ecx)
     4317         __(jne local_label(winapi_return))
     4318         __(repret)
     4319        __else
     4320         __(ret)
     4321        __endif
    430443222:      /* double-float return in x87 */
    43054323        __(fldl -8(%ebp))
    43064324        __(leave)
    4307         __(ret)         
     4325        __ifdef([WIN_32])
     4326         __(testl %ecx,%ecx)
     4327         __(jne local_label(winapi_return))
     4328         __(repret)
     4329        __else
     4330         __(ret)
     4331        __endif
     4332        __ifdef([WIN_32])
     4333local_label(winapi_return):             
     4334         /* %ecx is non-zero and contains count of arg words to pop */
     4335          __(popl -4(%esp,%ecx,4))
     4336          __(leal -4(%esp,%ecx,4),%esp)
     4337          __(ret)
     4338        __endif
    43084339_endsubp(callback)
    43094340
     
    43144345_spentry(aref2)
    43154346        __(testl $fixnummask,%arg_y)
    4316         __(je 0f)
    4317         __(uuo_error_reg_not_fixnum(Rarg_y))
    4318 0:      __(testb $fixnummask,%arg_z_b)
    4319         __(je 1f)
    4320         __(uuo_error_reg_not_fixnum(Rarg_z))
    4321 1:      __(extract_typecode(%temp0,%imm0))
     4347        __(jne 0f)
     4348        __(testb $fixnummask,%arg_z_b)
     4349        __(jne 1f)
     4350        __(extract_typecode(%temp0,%imm0))
    43224351        __(cmpb $subtag_arrayH,%imm0_b)
    43234352        __(jne 2f)
    43244353        __(cmpl $2<<fixnumshift,arrayH.rank(%temp0))
    4325         __(je 3f)
    4326 2:      __(uuo_error_reg_not_type(Rtemp0,error_object_not_array_2d))
    4327 3:      __(cmpl arrayH.dim0(%temp0),%arg_y)
    4328         __(jb 4f)
    4329         __(uuo_error_array_bounds(Rarg_y,Rtemp0))
    4330 4:      __(movl arrayH.dim0+node_size(%temp0),%imm0)
     4354        __(jne 2f)
     4355        __(cmpl arrayH.dim0(%temp0),%arg_y)
     4356        __(jae 3f)
     4357        __(movl arrayH.dim0+node_size(%temp0),%imm0)
    43314358        __(cmpl %imm0,%arg_z)
    4332         __(jb 5f)
    4333         __(uuo_error_array_bounds(Rarg_z,Rtemp0))
    4334 5:      __(sarl $fixnumshift,%imm0)
     4359        __(jae 4f)
     4360        __(sarl $fixnumshift,%imm0)
    43354361        __(imull %arg_y,%imm0)
    43364362        __(addl %imm0,%arg_z)
     
    43434369        __(ja C(misc_ref_common))
    43444370        __(jmp 6b)
     43710:      __(uuo_error_reg_not_fixnum(Rarg_y))
     43721:      __(uuo_error_reg_not_fixnum(Rarg_z))
     43732:      __(uuo_error_reg_not_type(Rtemp0,error_object_not_array_2d))
     43743:      __(uuo_error_array_bounds(Rarg_y,Rtemp0))
     43754:      __(uuo_error_array_bounds(Rarg_z,Rtemp0))
     4376
    43454377_endsubp(aref2)
    43464378
     4379/* Like aref2, but temp1 = array, temp0 = i, arg_y = j, arg_z = k */
    43474380_spentry(aref3)
    4348         __(int $3)
     4381        __(testb $fixnummask,%temp0_b)
     4382        __(jne 0f)
     4383        __(testl $fixnummask,%arg_y)
     4384        __(jne 1f)
     4385        __(testb $fixnummask,%arg_z_b)
     4386        __(jne 2f)
     4387        __(extract_typecode(%temp1,%imm0))
     4388        __(cmpb $subtag_arrayH,%imm0_b)
     4389        __(jne 3f)
     4390        __(cmpl $3<<fixnumshift,arrayH.rank(%temp1))
     4391        __(jne 3f)
     4392        __(cmpl arrayH.dim0(%temp1),%temp0)
     4393        __(jae 4f)
     4394        __(movl arrayH.dim0+node_size(%temp1),%imm0)
     4395        __(cmpl %imm0,%arg_y)
     4396        __(jae 5f)
     4397        __(cmpl arrayH.dim0+(node_size*2)(%temp1),%arg_z)
     4398        __(jae 6f)
     4399        /* index computation: k + dim2 * (j + dim1 * i) */
     4400        /* (plus minor fussing for fixnum scaling) */
     4401        __(sarl $fixnumshift,%imm0)
     4402        __(imull %imm0,%temp0)
     4403        __(addl %arg_y,%temp0)
     4404        __(movl arrayH.dim0+(node_size*2)(%temp1),%imm0)
     4405        __(sarl $fixnumshift,%imm0)
     4406        __(imull %imm0,%temp0)
     4407        __(addl %temp0,%arg_z)
     4408        __(movl %temp1,%arg_y)
     44098:      __(addl arrayH.displacement(%arg_y),%arg_z)
     4410        __(movl arrayH.data_vector(%arg_y),%arg_y)
     4411        __(extract_subtag(%arg_y,%imm0_b))
     4412        __(cmpb $subtag_vectorH,%imm0_b)
     4413        __(ja C(misc_ref_common))
     4414        __(jmp 8b)
     44150:      __(uuo_error_reg_not_fixnum(Rtemp0))
     44161:      __(uuo_error_reg_not_fixnum(Rarg_y))
     44172:      __(uuo_error_reg_not_fixnum(Rarg_z))
     44183:      __(uuo_error_reg_not_type(Rtemp1,error_object_not_array_3d))
     44194:      __(uuo_error_array_bounds(Rtemp0,Rtemp1))
     44205:      __(uuo_error_array_bounds(Rarg_y,Rtemp1))
     44216:      __(uuo_error_array_bounds(Rarg_z,Rtemp1))
    43494422_endsubp(aref3)
    43504423
     
    43524425_spentry(aset2)
    43534426        __(testb $fixnummask,%temp0_b)
    4354         __(je 0f)
    4355         __(uuo_error_reg_not_fixnum(Rtemp0))
    4356 0:      __(testl $fixnummask,%arg_y)
    4357         __(je 1f)
    4358         __(uuo_error_reg_not_fixnum(Rarg_y))
    4359 1:      __(extract_typecode(%temp1,%imm0))
     4427        __(jne 0f)
     4428        __(testl $fixnummask,%arg_y)
     4429        __(jne 1f)
     4430        __(extract_typecode(%temp1,%imm0))
    43604431        __(cmpb $subtag_arrayH,%imm0_b)
    43614432        __(jne 2f)
    43624433        __(cmpl $2<<fixnumshift,arrayH.rank(%temp1))
    4363         __(je 3f)
    4364 2:      __(uuo_error_reg_not_type(Rtemp1,error_object_not_array_2d))
    4365 3:      __(cmpl arrayH.dim0(%temp1),%temp0)
    4366         __(jb 4f)
    4367         __(uuo_error_array_bounds(Rtemp0,Rtemp1))
    4368 4:      __(movl arrayH.dim0+node_size(%temp1),%imm0)
     4434        __(jne 2f)
     4435        __(cmpl arrayH.dim0(%temp1),%temp0)
     4436        __(jae 3f)
     4437        __(movl arrayH.dim0+node_size(%temp1),%imm0)
    43694438        __(cmpl %imm0,%arg_y)
    4370         __(jb 5f)
    4371         __(uuo_error_array_bounds(Rarg_y,Rtemp1))
    4372 5:      __(sarl $fixnumshift,%imm0)
     4439        __(jae 4f)
     4440        __(sarl $fixnumshift,%imm0)
    43734441        __(imull %temp0,%imm0)
    43744442        __(addl %imm0,%arg_y)
     
    43814449        __(ja C(misc_set_common))
    43824450        __(jmp 6b)
     44510:      __(uuo_error_reg_not_fixnum(Rtemp0))
     44521:      __(uuo_error_reg_not_fixnum(Rarg_y))
     44532:      __(uuo_error_reg_not_type(Rtemp1,error_object_not_array_2d))
     44543:      __(uuo_error_array_bounds(Rtemp0,Rtemp1))
     44554:      __(uuo_error_array_bounds(Rarg_y,Rtemp1))
    43834456_endsubp(aset2)
    43844457
     4458/* temp1 = array, (%esp) = i, temp0 = j, arg_y = k, arg_z = newval */
    43854459_spentry(aset3)
    4386         __(int $3)
     4460        __(testb $fixnummask,(%esp))
     4461        __(jne 0f)
     4462        __(testb $fixnummask,%temp0_b)
     4463        __(jne 1f)
     4464        __(testl $fixnummask,%arg_y)
     4465        __(jne 2f)
     4466        __(extract_typecode(%temp1,%imm0))
     4467        __(cmpb $subtag_arrayH,%imm0_b)
     4468        __(jne 3f)
     4469        __(cmpl $3<<fixnumshift,arrayH.rank(%temp1))
     4470        __(jne 3f)
     4471        __(movl arrayH.dim0(%temp1),%imm0)
     4472        __(cmpl %imm0,(%esp))   /* i on stack */
     4473        __(jae 4f)
     4474        __(movl arrayH.dim0+node_size(%temp1),%imm0)
     4475        __(cmpl %imm0,%temp0)
     4476        __(jae 5f)
     4477        __(cmpl arrayH.dim0+(node_size*2)(%temp1),%arg_y)
     4478        __(jae 6f)
     4479        /* index computation: k + dim2 * (j + dim1 * i) */
     4480        /* (plus minor fussing for fixnum scaling) */
     4481        __(sarl $fixnumshift,%imm0)
     4482        __(imull (%esp),%imm0)  /* i on stack */
     4483        __(addl %imm0,%temp0)
     4484        __(addl $node_size,%esp)
     4485        __(movl arrayH.dim0+(node_size*2)(%temp1),%imm0)
     4486        __(sarl $fixnumshift,%imm0)
     4487        __(imull %imm0,%temp0)
     4488        __(addl %temp0,%arg_y)
     4489        __(movl %temp1,%temp0)
     44908:      __(addl arrayH.displacement(%temp0),%arg_y)
     4491        __(movl arrayH.data_vector(%temp0),%temp0)
     4492        __(extract_subtag(%temp0,%imm0_b))
     4493        __(cmpb $subtag_vectorH,%imm0_b)
     4494        __(ja C(misc_set_common))
     4495        __(jmp 8b)
     44960:      __(pop %temp0)  /* supplied i */
     4497        __(uuo_error_reg_not_fixnum(Rtemp0))
     44981:      __(uuo_error_reg_not_fixnum(Rtemp0))
     44992:      __(uuo_error_reg_not_fixnum(Rarg_y))
     45003:      __(uuo_error_reg_not_type(Rtemp1,error_object_not_array_3d))
     45014:      __(pop %imm0)   /* supplied i is on stack */
     4502        __(uuo_error_array_bounds(Rimm0,Rtemp1))
     45035:      __(uuo_error_array_bounds(Rtemp0,Rtemp1))
     45046:      __(uuo_error_array_bounds(Rarg_y,Rtemp1))
    43874505_endsubp(aset3)
    43884506
     
    45834701_endsubp(breakpoint)
    45844702
    4585 
    4586 /* %temp1 = array, %temp0 = i,%arg_y = j, %arg_z = k */
    4587 /*
    4588 _spentry(aref3)
    4589         __(testb $fixnummask,%temp0_b)
    4590         __(je 0f)
    4591         __(uuo_error_reg_not_fixnum(Rtemp0))
    4592 0:      __(testl $fixnummask,%arg_y)
    4593         __(je 1f)
    4594         __(uuo_error_reg_not_fixnum(Rarg_y))
    4595 1:      __(testb $fixnummask,%arg_z_b)
    4596         __(je 2f)
    4597         __(uuo_error_reg_not_fixnum(Rarg_z))
    4598 2:      __(extract_typecode(%temp1,%imm0))
    4599         __(cmpb $subtag_arrayH,%imm0_b)
    4600         __(jne 3f)
    4601         __(cmpl $3<<fixnumshift,arrayH.rank(%temp1))
    4602         __(je 4f)
    4603 3:      __(uuo_error_reg_not_type(Rtemp1,error_object_not_array_3d))
    4604 4:      __(cmpl arrayH.dim0(%temp1),%temp0)
    4605         __(jb 5f)
    4606         __(uuo_error_array_bounds(Rtemp0,Rtemp1))
    4607 5:      __(movl arrayH.dim0+node_size(%temp1),%imm0)
    4608         __(cmpl %imm0,%arg_y)
    4609         __(jb 6f)
    4610         __(uuo_error_array_bounds(Rarg_y,Rtemp1))
    4611 6:      __(unbox_fixnum(%imm0,%imm0))
    4612         __(movl arrayH.dim0+(node_size*2)(%temp1),%imm1)
    4613         __(cmpq %imm1,%arg_z)
    4614         __(jb 7f)
    4615         __(uuo_error_array_bounds(Rarg_z,Rtemp0))
    4616 7:      __(unbox_fixnum(%imm1,%imm1))
    4617         __(imulq %imm1,%arg_y)
    4618         __(mulq %imm1)
    4619         __(imulq %imm0,%arg_x)
    4620         __(addq %arg_x,%arg_z)
    4621         __(addq %arg_y,%arg_z)
    4622         __(movq %temp0,%arg_y)
    4623 8:      __(addq arrayH.displacement(%arg_y),%arg_z)
    4624         __(movq arrayH.data_vector(%arg_y),%arg_y)
    4625         __(extract_subtag(%arg_y,%imm1_b))
    4626         __(cmpb $subtag_vectorH,%imm1_b)
    4627         __(ja C(misc_ref_common))
    4628         __(jmp 8b)
    4629 _endsubp(aref3)
    4630 */       
    4631 
    4632 /* %temp1 = array, %imm0 = i, %temp0 = j, %arg_y = k, %arg_z = newval. */
    4633 /*
    4634 _spentry(aset3)
    4635         __(testb $fixnummask,%temp0_b)
    4636         __(je 0f)
    4637         __(uuo_error_reg_not_fixnum(Rtemp0))
    4638 0:      __(testb $fixnummask,%arg_x_b)
    4639         __(je 1f)
    4640         __(uuo_error_reg_not_fixnum(Rarg_x))
    4641 1:      __(testb $fixnummask,%arg_y_b)
    4642         __(je 2f)
    4643         __(uuo_error_reg_not_fixnum(Rarg_y))
    4644 2:      __(extract_typecode(%temp1,%imm0))
    4645         __(cmpb $subtag_arrayH,%imm0_b)
    4646         __(jne 3f)
    4647         __(cmpq $3<<fixnumshift,arrayH.rank(%temp1))
    4648         __(je 4f)
    4649 3:      __(uuo_error_reg_not_type(Rtemp1,error_object_not_array_3d))
    4650 4:      __(cmpq arrayH.dim0(%temp1),%temp0)
    4651         __(jb 5f)
    4652         __(uuo_error_array_bounds(Rtemp0,Rtemp1))
    4653 5:      __(movq arrayH.dim0+node_size(%temp1),%imm0)
    4654         __(cmpq %imm0,%arg_x)
    4655         __(jb 6f)
    4656         __(uuo_error_array_bounds(Rarg_x,Rtemp1))
    4657 6:      __(unbox_fixnum(%imm0,%imm0))
    4658         __(movq arrayH.dim0+(node_size*2)(%temp1),%imm1)
    4659         __(cmpq %imm1,%arg_y)
    4660         __(jb 7f)
    4661         __(uuo_error_array_bounds(Rarg_y,Rtemp1))
    4662 7:      __(unbox_fixnum(%imm1,%imm1))
    4663         __(imulq %imm1,%arg_x)
    4664         __(mulq %imm1)
    4665         __(imulq %imm0,%temp0)
    4666         __(addq %temp0,%arg_y)
    4667         __(addq %arg_x,%arg_y)
    4668         __(movq %temp1,%arg_x)
    4669 8:      __(addq arrayH.displacement(%arg_x),%arg_y)
    4670         __(movq arrayH.data_vector(%arg_x),%arg_x)
    4671         __(extract_subtag(%arg_x,%imm1_b))
    4672         __(cmpb $subtag_vectorH,%imm1_b)
    4673         __(ja C(misc_set_common))
    4674         __(jmp 8b)
    4675 _endsubp(aset3)
    4676 */
    4677 
    46784703_spentry(unused_6)
    46794704        __(int $3)
  • branches/working-0711/ccl/lisp-kernel/x86-subprims32.s

    r11074 r11267  
    2424        __(push $0)
    2525        __(mov %esp,%ebp)
     26        __(cmpl $0,C(GCDebug))
     27        __(je 1f)
     28        __(ref_global(initial_tcr,%imm0))
     29        __(cmpl rcontext(tcr.linear),%imm0)
     30        __(jne 1f)
    2631        __(clr %imm0)
    27         __(cmpl $0,C(GCDebug))
    28         __(jne 1f)
    2932        __(uuo_error_gc_trap)
    30331:
  • branches/working-0711/ccl/scripts/ccl

    r11101 r11267  
    99  CCL_DEFAULT_DIRECTORY=/usr/local/src/ccl
    1010fi
     11
     12export CCL_DEFAULT_DIRECTORY
    1113
    1214# This is shorter (& easier to type), making the invocation below
     
    3436              *86*) OPENMCL_KERNEL=lx86cl ;;
    3537           esac ;;
     38    CYGWIN*)
     39       OPENMCL_KERNEL=wx86cl.exe
     40       CCL_DEFAULT_DIRECTORY="C:/cygwin$CCL_DEFAULT_DIRECTORY"
     41    ;;
     42    SunOS) OPENMCL_KERNEL=sx86cl
     43    ;;
    3644    *)
    3745    echo "Can't determine host OS.  Fix this."
     
    4149fi
    4250
    43 CCL_DEFAULT_DIRECTORY=${DD} exec ${DD}/${OPENMCL_KERNEL} "$@"
     51exec ${DD}/${OPENMCL_KERNEL} "$@"
    4452
Note: See TracChangeset for help on using the changeset viewer.