Changeset 14619 for trunk/source/level-1


Ignore:
Timestamp:
Jan 31, 2011, 11:17:18 PM (8 years ago)
Author:
rme
Message:

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

Location:
trunk/source/level-1
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-lisp-threads.lisp

    r14367 r14619  
    194194
    195195(defun init-thread-from-tcr (tcr thread)
    196   (let* ((cs-area (%fixnum-ref tcr target::tcr.cs-area))
    197          (vs-area (%fixnum-ref tcr target::tcr.vs-area))
     196  (let* ((cs-area nil)
     197         (vs-area (%fixnum-ref tcr (- target::tcr.vs-area target::tcr-bias)))
    198198         #-arm-target
    199          (ts-area (%fixnum-ref tcr target::tcr.ts-area)))
     199         (ts-area (%fixnum-ref tcr (- target::tcr.ts-area target::tcr-bias))))
     200    #+(and windows-target x8632-target)
     201    (let ((aux (%fixnum-ref tcr (- target::tcr.aux target::tcr-bias))))
     202      (setq cs-area (%fixnum-ref aux target::tcr-aux.cs-area)))
     203    #-(and windows-target x8632-target)
     204    (setq cs-area (%fixnum-ref tcr target::tcr.cs-area))
    200205    (when (or (zerop cs-area)
    201206              (zerop vs-area)
     
    334339
    335340(defun tcr-flags (tcr)
    336   (%fixnum-ref tcr target::tcr.flags))
     341  (%fixnum-ref tcr (- target::tcr.flags target::tcr-bias)))
    337342
    338343
     
    361366  ;; When a thread dies, it should try to clear its interrupt-pending
    362367  ;; flag.
    363   (if (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending))
     368  (if (eql 0 (%fixnum-ref tcr (- target::tcr.interrupt-pending
     369                                 target::tcr-bias)))
    364370    (%%tcr-interrupt tcr)
    365371    0))
     
    415421  (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread))))
    416422    (with-macptrs (s)
     423      #+(and windows-target x8632-target)
     424      (let ((aux (%fixnum-ref tcr (- target::tcr.aux target::tcr-bias))))
     425        (%setf-macptr-to-object s (%fixnum-ref aux target::tcr-aux.reset-completion)))
     426      #-(and windows-target x8632-target)
    417427      (%setf-macptr-to-object s (%fixnum-ref tcr target::tcr.reset-completion))
    418428      (when (%timed-wait-on-semaphore-ptr s timeout nil)
     
    425435
    426436(defun cleanup-thread-tcr (thread tcr)
    427   (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
     437  (let* ((flags (%fixnum-ref tcr (- target::tcr.flags
     438                                    target::tcr-bias))))
    428439    (declare (fixnum flags))
    429440    (if (logbitp arch::tcr-flag-bit-awaiting-preset flags)
     
    447458    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
    448459    (unless (%null-ptr-p tcrp)
    449       (let* ((natural (%get-natural tcrp target::tcr.osid)))
     460     
     461      (let* ((natural #+(and windows-target x8632-target)
     462                      (%get-natural (%get-ptr tcrp (- target::tcr.aux
     463                                                      target::tcr-bias))
     464                                    target::tcr-aux.osid)
     465                      #-(and windows-target x8632-target)
     466                      (%get-natural tcrp target::tcr.osid)))
    450467        (unless (zerop natural) natural)))))
    451468
     
    466483    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
    467484    (unless (%null-ptr-p tcrp)
     485      #+(and windows-target x8632-target)
     486      (let ((aux (%get-ptr tcrp (- target::tcr.aux target::tcr-bias))))
     487        (%get-unsigned-long aux target::tcr-aux.native-thread-id))
     488      #-(and windows-target x8632-target)
    468489      (#+32-bit-target %get-unsigned-long
    469490       #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.native-thread-id))))
     
    473494    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
    474495    (unless (%null-ptr-p tcrp)
     496      #+(and windows-target x8632-target)
     497      (let ((aux (%get-ptr tcrp (- target::tcr.aux target::tcr-bias))))
     498        (%get-unsigned-long aux target::tcr-aux.suspend-count))
     499      #-(and windows-target x8632-target)
    475500      (#+32-bit-target %get-unsigned-long
    476501       #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.suspend-count))))
    477502
    478503(defun tcr-clear-preset-state (tcr)
    479   (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
     504  (let* ((flags (%fixnum-ref tcr (- target::tcr.flags target::tcr-bias))))
    480505    (declare (fixnum flags))
    481     (setf (%fixnum-ref tcr target::tcr.flags)
     506    (setf (%fixnum-ref tcr (- target::tcr.flags target::tcr-bias))
    482507          (bitclr arch::tcr-flag-bit-awaiting-preset flags))))
    483508
    484509(defun tcr-set-preset-state (tcr)
    485   (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
     510  (let* ((flags (%fixnum-ref tcr (- target::tcr.flags target::tcr-bias))))
    486511    (declare (fixnum flags))
    487     (setf (%fixnum-ref tcr target::tcr.flags)
     512    (setf (%fixnum-ref tcr (- target::tcr.flags target::tcr-bias))
    488513          (bitset arch::tcr-flag-bit-awaiting-preset flags)))) 
    489514
     
    494519    (with-macptrs (tcrp)
    495520      (%setf-macptr-to-object tcrp tcr)
     521      #+(and windows-target x8632-target)
     522      (let ((aux (%get-ptr tcrp (- target::tcr.aux target::tcr-bias))))
     523        (setf (%get-unsigned-long aux target::tcr-aux.log2-allocation-quantum)
     524              (or allocation-quantum (default-allocation-quantum))))
     525      #-(and windows-target x8632-target)
    496526      (setf (%get-natural tcrp target::tcr.log2-allocation-quantum)
    497527            (or allocation-quantum (default-allocation-quantum)))
     
    680710
    681711(defun %ptr-to-vstack-p (tcr idx)
    682   (%ptr-in-area-p idx (%fixnum-ref tcr target::tcr.vs-area)))
     712  (%ptr-in-area-p idx (%fixnum-ref tcr (- target::tcr.vs-area
     713                                          target::tcr-bias))))
    683714
    684715#-arm-target
    685716(defun %on-tsp-stack (tcr object)
    686   (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.ts-area)))
     717  (%ptr-in-area-p object (%fixnum-ref tcr (- target::tcr.ts-area
     718                                             target::tcr-bias))))
    687719
    688720(defun %on-csp-stack (tcr object)
    689   (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.cs-area)))
     721  (let ((cs-area #+(and windows-target x8632-target)
     722                 (%fixnum-ref (%fixnum-ref tcr (- target::tcr.aux
     723                                                  target::tcr-bias))
     724                              target::tcr-aux.cs-area)
     725                 #-(and windows-target x8632-target)
     726                 (%fixnum-ref tcr target::tcr.cs-area)))
     727    (%ptr-in-area-p object cs-area)))
    690728
    691729(defparameter *aux-tsp-ranges* ())
  • trunk/source/level-1/l1-processes.lisp

    r14362 r14619  
    317317(defmethod process-tcr-enable ((process process) tcr)
    318318  (when (and tcr (not (eql 0 tcr)))
     319    #+(and windows-target x8632-target)
     320    (let ((aux (%fixnum-ref tcr (- target::tcr.aux target::tcr-bias))))
     321      (%signal-semaphore-ptr (%fixnum-ref-macptr aux target::tcr-aux.activate)))
     322    #-(and windows-target x8632-target)
    319323    (%signal-semaphore-ptr (%fixnum-ref-macptr tcr target::tcr.activate))
    320324    ))
     
    695699    (with-macptrs (tcrp)
    696700      (%setf-macptr-to-object tcrp (%current-tcr))
    697       (setf (slot-value *current-process* 'allocation-quantum) new
    698             (%get-natural tcrp target::tcr.log2-allocation-quantum)
     701      #+(and windows-target x8632-target)
     702      (let ((aux (%get-ptr tcrp (- target::tcr.aux target::tcr-bias))))
     703        (setf (%get-natural aux target::tcr-aux.log2-allocation-quantum)
     704              (1- (integer-length new))))
     705      #-(and windows-target x8632-target)
     706      (setf (%get-natural tcrp target::tcr.log2-allocation-quantum)
    699707            (1- (integer-length new)))
     708      (setf (slot-value *current-process* 'allocation-quantum) new)
    700709      new)
    701710    (report-bad-arg new '(satisfies valid-allocation-quantum-p))))
  • trunk/source/level-1/x86-threads-utils.lisp

    r13067 r14619  
    2828       (locally (declare (fixnum p))
    2929         (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
    30                 (vs-area (%fixnum-ref tcr target::tcr.vs-area)))
     30                (vs-area (%fixnum-ref tcr (- target::tcr.vs-area
     31                                             target::tcr-bias))))
    3132           (not (%ptr-in-area-p p vs-area))))))
    3233
Note: See TracChangeset for help on using the changeset viewer.