protect against read-time package-lock circumvention from LOCKED::(BAR)
[sbcl.git] / src / compiler / saptran.lisp
1 ;;;; optimizations for SAP operations
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!C")
13 \f
14 ;;;; DEFKNOWNs
15
16 #!+linkage-table
17 (deftransform foreign-symbol-address ((symbol &optional datap) (simple-string boolean))
18   (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
19       `(sap-int (foreign-symbol-sap symbol datap))
20       (give-up-ir1-transform)))
21
22 (deftransform foreign-symbol-sap ((symbol &optional datap)
23                                       (simple-string &optional boolean))
24     #!-linkage-table
25     (if (null datap)
26         (give-up-ir1-transform)
27         `(foreign-symbol-sap symbol))
28     #!+linkage-table
29     (if (and (constant-lvar-p symbol) (constant-lvar-p datap))
30         (let ((name (lvar-value symbol))
31               (datap (lvar-value datap)))
32           (if (or #+sb-xc-host t ; only static symbols on host
33                   (not datap)
34                   (find-foreign-symbol-in-table name *static-foreign-symbols*))
35               `(foreign-symbol-sap ,name) ; VOP
36               `(foreign-symbol-dataref-sap ,name))) ; VOP
37         (give-up-ir1-transform)))
38
39 (defknown (sap< sap<= sap= sap>= sap>)
40           (system-area-pointer system-area-pointer) boolean
41   (movable flushable))
42
43 (defknown sap+ (system-area-pointer integer) system-area-pointer
44   (movable flushable))
45 (defknown sap- (system-area-pointer system-area-pointer)
46                (signed-byte #.sb!vm::n-word-bits)
47   (movable flushable))
48
49 (defknown sap-int (system-area-pointer)
50   (unsigned-byte #.sb!vm::n-machine-word-bits)
51   (movable flushable foldable))
52 (defknown int-sap ((unsigned-byte #.sb!vm::n-machine-word-bits))
53   system-area-pointer (movable))
54
55 (macrolet ((defsapref (fun value-type)
56              (let (#!+x86
57                    (with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun)))
58                    (set-fun (intern (format nil "%SET-~A" fun)))
59                    #!+x86
60                    (set-with-offset-fun (intern (format nil "%SET-~A-WITH-OFFSET" fun))))
61                `(progn
62                   (defknown ,fun (system-area-pointer fixnum) ,value-type
63                     (flushable))
64                   #!+x86
65                   (defknown ,with-offset-fun (system-area-pointer fixnum fixnum) ,value-type
66                     (flushable always-translatable))
67                   (defknown ,set-fun (system-area-pointer fixnum ,value-type) ,value-type
68                     ())
69                   #!+x86
70                   (defknown ,set-with-offset-fun (system-area-pointer fixnum fixnum ,value-type) ,value-type
71                     (always-translatable))))))
72   (defsapref sap-ref-8 (unsigned-byte 8))
73   (defsapref sap-ref-16 (unsigned-byte 16))
74   (defsapref sap-ref-32 (unsigned-byte 32))
75   (defsapref sap-ref-64 (unsigned-byte 64))
76   (defsapref sap-ref-word (unsigned-byte #.sb!vm:n-word-bits))
77   (defsapref signed-sap-ref-8 (signed-byte 8))
78   (defsapref signed-sap-ref-16 (signed-byte 16))
79   (defsapref signed-sap-ref-32 (signed-byte 32))
80   (defsapref signed-sap-ref-64 (signed-byte 64))
81   (defsapref signed-sap-ref-word (signed-byte #.sb!vm:n-word-bits))
82   (defsapref sap-ref-sap system-area-pointer)
83   (defsapref sap-ref-lispobj t)
84   (defsapref sap-ref-single single-float)
85   (defsapref sap-ref-double double-float)
86   (defsapref sap-ref-long long-float)
87 ) ; MACROLET
88
89 \f
90 ;;;; transforms for converting sap relation operators
91
92 (macrolet ((def (sap-fun int-fun)
93              `(deftransform ,sap-fun ((x y) * *)
94                 `(,',int-fun (sap-int x) (sap-int y)))))
95   (def sap< <)
96   (def sap<= <=)
97   (def sap= =)
98   (def sap>= >=)
99   (def sap> >))
100 \f
101 ;;;; transforms for optimizing SAP+
102
103 (deftransform sap+ ((sap offset))
104   (cond ((and (constant-lvar-p offset)
105               (eql (lvar-value offset) 0))
106          'sap)
107         (t
108          (splice-fun-args sap 'sap+ 2)
109          '(lambda (sap offset1 offset2)
110             (sap+ sap (+ offset1 offset2))))))
111
112 (macrolet ((def (fun &optional setp value-type)
113              (declare (ignorable value-type))
114              `(progn
115                 (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *)
116                   (splice-fun-args sap 'sap+ 2)
117                   `(lambda (sap offset1 offset2 ,@',(when setp `(new-value)))
118                      (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value)))))
119                 ;; Avoid defining WITH-OFFSET transforms for accessors whose
120                 ;; sizes are larger than the word size; they'd probably be
121                 ;; pointless to optimize anyway and tricky to boot.
122                 ,(unless (and (listp value-type)
123                               (or (eq (first value-type) 'unsigned-byte)
124                                   (eq (first value-type) 'signed-byte))
125                               (> (second value-type) sb!vm:n-word-bits))
126                    #!+x86
127                    (let ((with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun))))
128                      `(progn
129                         ,(cond
130                           (setp
131                            `(deftransform ,fun ((sap offset new-value)
132                                                 (system-area-pointer fixnum ,value-type) *)
133                              `(,',with-offset-fun sap (truly-the fixnum offset) 0 new-value)))
134                           (t
135                            `(deftransform ,fun ((sap offset) (system-area-pointer fixnum) *)
136                               `(,',with-offset-fun sap (truly-the fixnum offset) 0))))
137                         (deftransform ,with-offset-fun ((sap offset disp
138                                                              ,@(when setp `(new-value))) * *)
139                           (fold-index-addressing ',with-offset-fun
140                                                  8 ; all sap-offsets are in bytes
141                                                  0 ; lowtag
142                                                  0 ; data offset
143                                                  offset disp ,setp))))))))
144   (def sap-ref-8)
145   (def %set-sap-ref-8 t (unsigned-byte 8))
146   (def signed-sap-ref-8)
147   (def %set-signed-sap-ref-8 t (signed-byte 8))
148   (def sap-ref-16)
149   (def %set-sap-ref-16 t (unsigned-byte 16))
150   (def signed-sap-ref-16)
151   (def %set-signed-sap-ref-16 t (signed-byte 16))
152   (def sap-ref-32)
153   (def %set-sap-ref-32 t (unsigned-byte 32))
154   (def signed-sap-ref-32)
155   (def %set-signed-sap-ref-32 t (signed-byte 32))
156   (def sap-ref-64)
157   (def %set-sap-ref-64 t (unsigned-byte 64))
158   (def signed-sap-ref-64)
159   (def %set-signed-sap-ref-64 t (signed-byte 64))
160   (def sap-ref-sap)
161   (def %set-sap-ref-sap t system-area-pointer)
162   (def sap-ref-lispobj)
163   (def %set-sap-ref-lispobj t t)
164   (def sap-ref-single)
165   (def %set-sap-ref-single t single-float)
166   (def sap-ref-double)
167   (def %set-sap-ref-double t double-float)
168   #!+long-float (def sap-ref-long)
169   #!+long-float (def %set-sap-ref-long t long-float))
170
171 (macrolet ((def (fun args 32-bit 64-bit)
172                `(deftransform ,fun (,args)
173                   (ecase sb!vm::n-word-bits
174                     (32 '(,32-bit ,@args))
175                     (64 '(,64-bit ,@args))))))
176   (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
177   (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
178   (def %set-sap-ref-word (sap offset value)
179     %set-sap-ref-32 %set-sap-ref-64)
180   (def %set-signed-sap-ref-word (sap offset value)
181     %set-signed-sap-ref-32 %set-signed-sap-ref-64))
182 \f
183 ;;; Transforms for 64-bit SAP accessors on 32-bit platforms.
184
185 #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
186 (progn
187 #!+#.(cl:if (cl:eq :little-endian sb!c:*backend-byte-order*) '(and) '(or))
188 (progn
189   (deftransform sap-ref-64 ((sap offset) (* *))
190     '(logior (sap-ref-32 sap offset)
191              (ash (sap-ref-32 sap (+ offset 4)) 32)))
192
193   (deftransform signed-sap-ref-64 ((sap offset) (* *))
194     '(logior (sap-ref-32 sap offset)
195              (ash (signed-sap-ref-32 sap (+ offset 4)) 32)))
196
197   (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
198     '(progn
199        (%set-sap-ref-32 sap offset (logand value #xffffffff))
200        (%set-sap-ref-32 sap (+ offset 4) (ash value -32))))
201
202   (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
203     '(progn
204        (%set-sap-ref-32 sap offset (logand value #xffffffff))
205        (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32)))))
206
207 #!+#.(cl:if (cl:eq :big-endian sb!c:*backend-byte-order*) '(and) '(or))
208 (progn
209   (deftransform sap-ref-64 ((sap offset) (* *))
210     '(logior (ash (sap-ref-32 sap offset) 32)
211              (sap-ref-32 sap (+ offset 4))))
212
213   (deftransform signed-sap-ref-64 ((sap offset) (* *))
214     '(logior (ash (signed-sap-ref-32 sap offset) 32)
215              (sap-ref-32 sap (+ 4 offset))))
216
217   (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
218     '(progn
219        (%set-sap-ref-32 sap offset (ash value -32))
220        (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
221
222   (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
223     '(progn
224        (%set-signed-sap-ref-32 sap offset (ash value -32))
225        (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))))
226 ) ; (= 32 SB!VM:N-MACHINE-WORD-BITS)