1.0.29.13: relax CAST-EXTERNALLY-CHECKABLE-P a bit
[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-single single-float)
84   (defsapref sap-ref-double double-float)
85   (defsapref sap-ref-long long-float)
86 ) ; MACROLET
87
88 \f
89 ;;;; transforms for converting sap relation operators
90
91 (macrolet ((def (sap-fun int-fun)
92              `(deftransform ,sap-fun ((x y) * *)
93                 `(,',int-fun (sap-int x) (sap-int y)))))
94   (def sap< <)
95   (def sap<= <=)
96   (def sap= =)
97   (def sap>= >=)
98   (def sap> >))
99 \f
100 ;;;; transforms for optimizing SAP+
101
102 (deftransform sap+ ((sap offset))
103   (cond ((and (constant-lvar-p offset)
104               (eql (lvar-value offset) 0))
105          'sap)
106         (t
107          (splice-fun-args sap 'sap+ 2)
108          '(lambda (sap offset1 offset2)
109             (sap+ sap (+ offset1 offset2))))))
110
111 (macrolet ((def (fun element-size &optional setp value-type)
112              (declare (ignorable value-type)
113                       #!-x86 (ignore element-size))
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                                                  ,element-size
141                                                  0 ; lowtag
142                                                  0 ; data offset
143                                                  offset disp ,setp))))))))
144   (def sap-ref-8 8)
145   (def %set-sap-ref-8 8 t (unsigned-byte 8))
146   (def signed-sap-ref-8 8)
147   (def %set-signed-sap-ref-8 8 t (signed-byte 8))
148   (def sap-ref-16 16)
149   (def %set-sap-ref-16 16 t (unsigned-byte 16))
150   (def signed-sap-ref-16 16)
151   (def %set-signed-sap-ref-16 16 t (signed-byte 16))
152   (def sap-ref-32 32)
153   (def %set-sap-ref-32 32 t (unsigned-byte 32))
154   (def signed-sap-ref-32 32)
155   (def %set-signed-sap-ref-32 32 t (signed-byte 32))
156   (def sap-ref-64 64)
157   (def %set-sap-ref-64 64 t (unsigned-byte 64))
158   (def signed-sap-ref-64 64)
159   (def %set-signed-sap-ref-64 64 t (signed-byte 64))
160   (def sap-ref-sap sb!vm:n-word-bits)
161   (def %set-sap-ref-sap sb!vm:n-word-bits t system-area-pointer)
162   (def sap-ref-single 32)
163   (def %set-sap-ref-single 32 t single-float)
164   (def sap-ref-double 64)
165   (def %set-sap-ref-double 64 t double-float)
166   #!+long-float (def sap-ref-long 96)
167   #!+long-float (def %set-sap-ref-long 96 t 8))
168
169 (macrolet ((def (fun args 32-bit 64-bit)
170                `(deftransform ,fun (,args)
171                   (ecase sb!vm::n-word-bits
172                     (32 '(,32-bit ,@args))
173                     (64 '(,64-bit ,@args))))))
174   (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64)
175   (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64)
176   (def %set-sap-ref-word (sap offset value)
177     %set-sap-ref-32 %set-sap-ref-64)
178   (def %set-signed-sap-ref-word (sap offset value)
179     %set-signed-sap-ref-32 %set-signed-sap-ref-64))