1 ;;;; optimizations for SAP operations
3 ;;;; This software is part of the SBCL system. See the README file for
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.
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)))
22 (deftransform foreign-symbol-sap ((symbol &optional datap)
23 (simple-string &optional boolean))
26 (give-up-ir1-transform)
27 `(foreign-symbol-sap symbol))
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
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)))
39 (defknown (sap< sap<= sap= sap>= sap>)
40 (system-area-pointer system-area-pointer) boolean
43 (defknown sap+ (system-area-pointer integer) system-area-pointer
45 (defknown sap- (system-area-pointer system-area-pointer)
46 (signed-byte #.sb!vm::n-word-bits)
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))
55 (macrolet ((defsapref (fun value-type)
57 (with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun)))
58 (set-fun (intern (format nil "%SET-~A" fun)))
60 (set-with-offset-fun (intern (format nil "%SET-~A-WITH-OFFSET" fun))))
62 (defknown ,fun (system-area-pointer fixnum) ,value-type
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
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-single single-float)
84 (defsapref sap-ref-double double-float)
85 (defsapref sap-ref-long long-float)
89 ;;;; transforms for converting sap relation operators
91 (macrolet ((def (sap-fun int-fun)
92 `(deftransform ,sap-fun ((x y) * *)
93 `(,',int-fun (sap-int x) (sap-int y)))))
100 ;;;; transforms for optimizing SAP+
102 (deftransform sap+ ((sap offset))
103 (cond ((and (constant-lvar-p offset)
104 (eql (lvar-value offset) 0))
107 (splice-fun-args sap 'sap+ 2)
108 '(lambda (sap offset1 offset2)
109 (sap+ sap (+ offset1 offset2))))))
111 (macrolet ((def (fun &optional setp value-type)
112 (declare (ignorable value-type))
114 (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *)
115 (splice-fun-args sap 'sap+ 2)
116 `(lambda (sap offset1 offset2 ,@',(when setp `(new-value)))
117 (,',fun sap (+ offset1 offset2) ,@',(when setp `(new-value)))))
118 ;; Avoid defining WITH-OFFSET transforms for accessors whose
119 ;; sizes are larger than the word size; they'd probably be
120 ;; pointless to optimize anyway and tricky to boot.
121 ,(unless (and (listp value-type)
122 (or (eq (first value-type) 'unsigned-byte)
123 (eq (first value-type) 'signed-byte))
124 (> (second value-type) sb!vm:n-word-bits))
126 (let ((with-offset-fun (intern (format nil "~A-WITH-OFFSET" fun))))
130 `(deftransform ,fun ((sap offset new-value)
131 (system-area-pointer fixnum ,value-type) *)
132 `(,',with-offset-fun sap (truly-the fixnum offset) 0 new-value)))
134 `(deftransform ,fun ((sap offset) (system-area-pointer fixnum) *)
135 `(,',with-offset-fun sap (truly-the fixnum offset) 0))))
136 (deftransform ,with-offset-fun ((sap offset disp
137 ,@(when setp `(new-value))) * *)
138 (fold-index-addressing ',with-offset-fun
139 8 ; all sap-offsets are in bytes
142 offset disp ,setp))))))))
144 (def %set-sap-ref-8 t (unsigned-byte 8))
145 (def signed-sap-ref-8)
146 (def %set-signed-sap-ref-8 t (signed-byte 8))
148 (def %set-sap-ref-16 t (unsigned-byte 16))
149 (def signed-sap-ref-16)
150 (def %set-signed-sap-ref-16 t (signed-byte 16))
152 (def %set-sap-ref-32 t (unsigned-byte 32))
153 (def signed-sap-ref-32)
154 (def %set-signed-sap-ref-32 t (signed-byte 32))
156 (def %set-sap-ref-64 t (unsigned-byte 64))
157 (def signed-sap-ref-64)
158 (def %set-signed-sap-ref-64 t (signed-byte 64))
160 (def %set-sap-ref-sap t system-area-pointer)
162 (def %set-sap-ref-single t single-float)
164 (def %set-sap-ref-double t double-float)
165 #!+long-float (def sap-ref-long)
166 #!+long-float (def %set-sap-ref-long t long-float))
168 (macrolet ((def (fun args 32-bit 64-bit)
169 `(deftransform ,fun (,args)
170 (ecase sb!vm::n-word-bits
171 (32 '(,32-bit ,@args))
172 (64 '(,64-bit ,@args))))))
173 (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
174 (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
175 (def %set-sap-ref-word (sap offset value)
176 %set-sap-ref-32 %set-sap-ref-64)
177 (def %set-signed-sap-ref-word (sap offset value)
178 %set-signed-sap-ref-32 %set-signed-sap-ref-64))
180 ;;; Transforms for 64-bit SAP accessors on 32-bit platforms.
182 #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
184 #!+#.(cl:if (cl:eq :little-endian sb!c:*backend-byte-order*) '(and) '(or))
186 (deftransform sap-ref-64 ((sap offset) (* *))
187 '(logior (sap-ref-32 sap offset)
188 (ash (sap-ref-32 sap (+ offset 4)) 32)))
190 (deftransform signed-sap-ref-64 ((sap offset) (* *))
191 '(logior (sap-ref-32 sap offset)
192 (ash (signed-sap-ref-32 sap (+ offset 4)) 32)))
194 (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
196 (%set-sap-ref-32 sap offset (logand value #xffffffff))
197 (%set-sap-ref-32 sap (+ offset 4) (ash value -32))))
199 (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
201 (%set-sap-ref-32 sap offset (logand value #xffffffff))
202 (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32)))))
204 #!+#.(cl:if (cl:eq :big-endian sb!c:*backend-byte-order*) '(and) '(or))
206 (deftransform sap-ref-64 ((sap offset) (* *))
207 '(logior (ash (sap-ref-32 sap offset) 32)
208 (sap-ref-32 sap (+ offset 4))))
210 (deftransform signed-sap-ref-64 ((sap offset) (* *))
211 '(logior (ash (signed-sap-ref-32 sap offset) 32)
212 (sap-ref-32 sap (+ 4 offset))))
214 (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
216 (%set-sap-ref-32 sap offset (ash value -32))
217 (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
219 (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
221 (%set-signed-sap-ref-32 sap offset (ash value -32))
222 (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))))
223 ) ; (= 32 SB!VM:N-MACHINE-WORD-BITS)