Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[f05756]: src / compiler / saptran.lisp Maximize Restore History

Download this file

saptran.lisp    236 lines (210 with data), 9.9 kB

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