source: trunk/source/level-1/x86-threads-utils.lisp @ 15278

Last change on this file since 15278 was 14619, checked in by rme, 10 years ago

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"

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.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.4 KB
[3942]1;;; x86-trap-support
[13067]3;;;   Copyright (C) 2005-2009 Clozure Associates and contributors
[13066]4;;;   This file is part of Clozure CL. 
[13066]6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
[3942]8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[3942]10;;;   conflict, the preamble takes precedence. 
[13066]12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;   The LLGPL is also available online at
18(in-package "CCL")
21(defun %frame-backlink (p &optional context)
[4450]22  (declare (ignore context))
23  (cond ((fixnump p) (%%frame-backlink p))
[3942]24        (t (error "~s is not a valid stack frame" p))))
26(defun bottom-of-stack-p (p context)
27  (and (fixnump p)
28       (locally (declare (fixnum p))
29         (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
[14619]30                (vs-area (%fixnum-ref tcr (- target::tcr.vs-area
31                                             target::tcr-bias))))
[3942]32           (not (%ptr-in-area-p p vs-area))))))
35(defun lisp-frame-p (p context)
[4450]36  (declare (fixnum p))
37  (let ((next-frame (%frame-backlink p context)))
38    (declare (fixnum next-frame))
39    (if (bottom-of-stack-p next-frame context)
40        (values nil t)
41        (values t nil))))
44(defun catch-frame-sp (catch)
[10128]45  (uvref catch
46         #+x8632-target x8632::catch-frame.ebp-cell
47         #+x8664-target x8664::catch-frame.rbp-cell))
[4185]49;;; Sure would be nice to have &optional in defppclapfunction arglists
50;;; Sure would be nice not to do this at runtime.
[4185]52(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
53  (lfun-bits #'%fixnum-ref
54             (dpb (ldb $lfbits-numreq bits)
55                  $lfbits-numreq
56                  (dpb (ldb $lfbits-numopt bits)
57                       $lfbits-numopt
58                       (lfun-bits #'%fixnum-ref)))))
[4185]60(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
61  (lfun-bits #'%fixnum-ref-natural
62             (dpb (ldb $lfbits-numreq bits)
63                  $lfbits-numreq
64                  (dpb (ldb $lfbits-numopt bits)
65                       $lfbits-numopt
66                       (lfun-bits #'%fixnum-ref-natural)))))
69;;; Sure would be nice to have &optional in defppclapfunction arglists
70;;; Sure would be nice not to do this at runtime.
72(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
73  (lfun-bits #'%fixnum-ref
74             (dpb (ldb $lfbits-numreq bits)
75                  $lfbits-numreq
76                  (dpb (ldb $lfbits-numopt bits)
77                       $lfbits-numopt
78                       (lfun-bits #'%fixnum-ref)))))
80(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y))))))
81  (lfun-bits #'%fixnum-ref-natural
82             (dpb (ldb $lfbits-numreq bits)
83                  $lfbits-numreq
84                  (dpb (ldb $lfbits-numopt bits)
85                       $lfbits-numopt
86                       (lfun-bits #'%fixnum-ref-natural)))))
88(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
89  (lfun-bits #'%fixnum-set
90             (dpb (ldb $lfbits-numreq bits)
91                  $lfbits-numreq
92                  (dpb (ldb $lfbits-numopt bits)
93                       $lfbits-numopt
94                       (lfun-bits #'%fixnum-set)))))
96(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z))))))
97  (lfun-bits #'%fixnum-set-natural
98             (dpb (ldb $lfbits-numreq bits)
99                  $lfbits-numreq
100                  (dpb (ldb $lfbits-numopt bits)
101                       $lfbits-numopt
102                       (lfun-bits #'%fixnum-set-natural)))))
106(defun valid-subtag-p (subtag)
107  (declare (fixnum subtag))
108  (let* ((tagval (ldb (byte (- x8632::num-subtag-bits x8632::ntagbits) x8632::ntagbits) subtag)))
109    (declare (fixnum tagval))
110    (case (logand subtag x8632::fulltagmask)
111      (#. x8632::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
112      (#. x8632::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
113      (t nil))))
[4562]116(defun valid-subtag-p (subtag)
117  (declare (fixnum subtag))
118  (let* ((tagval (logand x8664::fulltagmask subtag))
119         (high4 (ash subtag (- x8664::ntagbits))))
120    (declare (fixnum tagval high4))
121    (not (eq 'bogus
122             (case tagval
123               (#.x8664::fulltag-immheader-0
124                (%svref *immheader-0-types* high4))
125               (#.x8664::fulltag-immheader-1
126                (%svref *immheader-1-types* high4))
127               (#.x8664::fulltag-immheader-2
128                (%svref *immheader-2-types* high4))
129               (#.x8664::fulltag-nodeheader-0
130                (%svref *nodeheader-0-types* high4))
131               (#.x8664::fulltag-nodeheader-1
132                (%svref *nodeheader-1-types* high4))
133               (t 'bogus))))))
[4562]136(defun valid-header-p (thing)
137  (let* ((fulltag (fulltag thing)))
138    (declare (fixnum fulltag))
139    (case fulltag
[10128]140      (#.x8632::fulltag-misc (valid-subtag-p (typecode thing)))
141      ((#.x8632::fulltag-immheader #.x8632::fulltag-nodeheader) nil)
142      (t t))))
145(defun valid-header-p (thing)
146  (let* ((fulltag (fulltag thing)))
147    (declare (fixnum fulltag))
148    (case fulltag
[4562]149      ((#.x8664::fulltag-even-fixnum
150        #.x8664::fulltag-odd-fixnum
151        #.x8664::fulltag-imm-0
152        #.x8664::fulltag-imm-1)
153       t)
154      (#.x8664::fulltag-function
155       (= x8664::subtag-function (typecode (%function-to-function-vector thing))))
156      (#.x8664::fulltag-symbol
157       (= x8664::subtag-symbol (typecode (%symptr->symvector thing))))
158      (#.x8664::fulltag-misc
159       (valid-subtag-p (typecode thing)))
160      ((#.x8664::fulltag-tra-0
161        #.x8664::fulltag-tra-1)
162       (let* ((disp (%return-address-offset thing)))
[11065]163         (and disp
164              (let* ((f (%return-address-function thing)))
165                (and (typep f 'function) (valid-header-p f))))))
[4562]166      (#.x8664::fulltag-cons t)
167      (#.x8664::fulltag-nil (null thing))
168      (t nil))))
171(defun bogus-thing-p (x)
172  (when x
173    (or (not (valid-header-p x))
174        (let ((tag (lisptag x))
175              (fulltag (fulltag x)))
176          (unless (or (eql tag x8632::tag-fixnum)
177                      (eql tag x8632::tag-imm)
178                      (in-any-consing-area-p x)
179                      (temporary-cons-p x)
180                      (and (or (typep x 'function)
181                               (typep x 'gvector))
182                           (on-any-tsp-stack x))
183                      (and (eql fulltag x8632::fulltag-tra)
[11065]184                           (%return-address-offset x))
[10128]185                      (and (typep x 'ivector)
186                           (on-any-csp-stack x))
187                      (%heap-ivector-p x))
188            t)))))
[4543]191(defun bogus-thing-p (x)
[4562]192  (when x
193    (or (not (valid-header-p x))
194        (let* ((tag (lisptag x)))
195          (unless (or (eql tag x8664::tag-fixnum)
196                      (eql tag x8664::tag-imm-0)
197                      (eql tag x8664::tag-imm-1)
198                      (in-any-consing-area-p x)
199                      (temporary-cons-p x)
200                      (and (or (typep x 'function)
201                               (typep x 'gvector))
202                           (on-any-tsp-stack x))
203                      (and (eql tag x8664::tag-tra)
204                           (eql 0 (%return-address-offset x)))
205                      (and (typep x 'ivector)
[5067]206                           (on-any-csp-stack x))
207                      (%heap-ivector-p x))
[4562]208            t)))))
Note: See TracBrowser for help on using the repository browser.