/[cmucl]/src/compiler/saptran.lisp
ViewVC logotype

Contents of /src/compiler/saptran.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Fri Mar 19 15:19:01 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.18: +3 -2 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Log: C.Log; Package: C -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/saptran.lisp,v 1.19 2010/03/19 15:19:01 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains some magic hacks for optimizing SAP operations.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16 (in-package "C")
17 (intl:textdomain "cmucl")
18
19
20
21 ;;;; Defknowns
22
23
24 (defknown foreign-symbol-address (simple-string &key (:flavor t))
25 system-area-pointer
26 (movable flushable))
27
28 (defknown foreign-symbol-code-address (simple-string) system-area-pointer
29 (movable flushable))
30
31 (defknown foreign-symbol-data-address (simple-string) system-area-pointer
32 (movable flushable))
33
34 ;;; Preserve compatibility for ports that don't use linkage table yet
35 (deftransform foreign-symbol-address ((symbol &key flavor)
36 (simple-string &rest *))
37 #-linkage-table
38 (when (null flavor)
39 (give-up))
40 #+linkage-table
41 (unless (constant-continuation-p symbol)
42 (give-up))
43 (let ((flav (cond ((null flavor) :code)
44 ((not (constant-continuation-p flavor))
45 (give-up))
46 (t (continuation-value flavor)))))
47 (case flav
48 (:code
49 `(#+linkage-table foreign-symbol-code-address
50 #-linkage-table foreign-symbol-address
51 symbol))
52 (:data
53 `(#+linkage-table foreign-symbol-data-address
54 #-linkage-table foreign-symbol-address
55 symbol))
56 (t
57 (compiler-error
58 _N"FOREIGN-SYMBOL-ADDRESS flavor ~S is not :CODE or :DATA" flav)))))
59
60 (defknown (sap< sap<= sap= sap>= sap>)
61 (system-area-pointer system-area-pointer) boolean
62 (movable flushable))
63
64 (defknown sap+ (system-area-pointer integer) system-area-pointer
65 (movable flushable))
66 (defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
67 (movable flushable))
68
69 (defknown sap-int (system-area-pointer) (unsigned-byte #-alpha 32 #+alpha 64)
70 (movable flushable))
71 (defknown int-sap ((unsigned-byte #-alpha 32 #+alpha 64))
72 system-area-pointer (movable))
73
74
75 (defknown sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64))
76 (unsigned-byte 8)
77 (flushable))
78 (defknown %set-sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64)
79 (unsigned-byte 8))
80 (unsigned-byte 8)
81 ())
82
83 (defknown sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63))
84 (unsigned-byte 16)
85 (flushable))
86 (defknown %set-sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63)
87 (unsigned-byte 16))
88 (unsigned-byte 16)
89 ())
90
91 (defknown sap-ref-32 (system-area-pointer fixnum) (unsigned-byte 32)
92 (flushable))
93 (defknown %set-sap-ref-32 (system-area-pointer fixnum (unsigned-byte 32))
94 (unsigned-byte 32)
95 ())
96
97 (defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64)
98 (flushable))
99 (defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64))
100 (unsigned-byte 64)
101 ())
102
103
104 (defknown signed-sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64))
105 (signed-byte 8)
106 (flushable))
107 (defknown %set-signed-sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64)
108 (signed-byte 8))
109 (signed-byte 8)
110 ())
111
112 (defknown signed-sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63))
113 (signed-byte 16)
114 (flushable))
115 (defknown %set-signed-sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63)
116 (signed-byte 16))
117 (signed-byte 16)
118 ())
119
120 (defknown signed-sap-ref-32 (system-area-pointer fixnum) (signed-byte 32)
121 (flushable))
122 (defknown %set-signed-sap-ref-32 (system-area-pointer fixnum (signed-byte 32))
123 (signed-byte 32)
124 ())
125
126 (defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64)
127 (flushable))
128 (defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64))
129 (signed-byte 64)
130 ())
131
132
133 (defknown sap-ref-sap (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64))
134 system-area-pointer
135 (flushable))
136 (defknown %set-sap-ref-sap (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64)
137 system-area-pointer)
138 system-area-pointer
139 ())
140
141 (defknown sap-ref-single (system-area-pointer fixnum) single-float
142 (flushable))
143 (defknown sap-ref-double (system-area-pointer fixnum) double-float
144 (flushable))
145 #+(or x86 amd64 long-float)
146 (defknown sap-ref-long (system-area-pointer fixnum) long-float
147 (flushable))
148
149 (defknown %set-sap-ref-single
150 (system-area-pointer fixnum single-float) single-float
151 ())
152 (defknown %set-sap-ref-double
153 (system-area-pointer fixnum double-float) double-float
154 ())
155 #+(or x86 long-float)
156 (defknown %set-sap-ref-long
157 (system-area-pointer fixnum long-float) long-float
158 ())
159
160
161 ;;;; Transforms for converting sap relation operators.
162
163 (dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >)))
164 (destructuring-bind (sap-fun int-fun) info
165 (deftransform sap-fun ((x y) '* '* :eval-name t)
166 `(,int-fun (sap-int x) (sap-int y)))))
167
168
169 ;;;; Transforms for optimizing sap+
170
171 (deftransform sap+ ((sap offset))
172 (cond ((and (constant-continuation-p offset)
173 (eql (continuation-value offset) 0))
174 'sap)
175 (t
176 (extract-function-args sap 'sap+ 2)
177 '(lambda (sap offset1 offset2)
178 (sap+ sap (+ offset1 offset2))))))
179
180 (dolist (fun '(sap-ref-8 %set-sap-ref-8
181 signed-sap-ref-8 %set-signed-sap-ref-8
182 sap-ref-16 %set-sap-ref-16
183 signed-sap-ref-16 %set-signed-sap-ref-16
184 sap-ref-32 %set-sap-ref-32
185 signed-sap-ref-32 %set-signed-sap-ref-32
186 sap-ref-64 %set-sap-ref-64
187 signed-sap-ref-64 %set-signed-sap-ref-64
188 sap-ref-sap %set-sap-ref-sap
189 sap-ref-single %set-sap-ref-single
190 sap-ref-double %set-sap-ref-double
191 #+(or x86 long-float) sap-ref-long
192 #+long-float %set-sap-ref-long))
193 (deftransform fun ((sap offset) '* '* :eval-name t)
194 (extract-function-args sap 'sap+ 2)
195 `(lambda (sap offset1 offset2)
196 (,fun sap (+ offset1 offset2)))))

  ViewVC Help
Powered by ViewVC 1.1.5