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

Contents of /src/compiler/aliencomp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, 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-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.32: +35 -35 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
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/aliencomp.lisp,v 1.33 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains transforms and other stuff used to compile Alien
13 ;;; operations.
14 ;;;
15 ;;; Rewritten once again, this time by William Lott and Rob MacLachlan.
16 ;;;
17 (in-package "C")
18 (use-package "ALIEN")
19 (use-package "SYSTEM")
20
21 (intl:textdomain "cmucl")
22
23 (export '(%alien-funcall))
24
25
26 ;;;; defknowns
27
28 (defknown %sap-alien (system-area-pointer alien-type) alien-value
29 (flushable movable))
30 (defknown alien-sap (alien-value) system-area-pointer
31 (flushable movable))
32
33 (defknown slot (alien-value symbol) t
34 (flushable recursive))
35 (defknown %set-slot (alien-value symbol t) t
36 (recursive))
37 (defknown %slot-addr (alien-value symbol) (alien (* t))
38 (flushable movable recursive))
39
40 (defknown deref (alien-value &rest index) t
41 (flushable))
42 (defknown %set-deref (alien-value t &rest index) t
43 ())
44 (defknown %deref-addr (alien-value &rest index) (alien (* t))
45 (flushable movable))
46
47 (defknown %heap-alien (heap-alien-info) t
48 (flushable))
49 (defknown %set-heap-alien (heap-alien-info t) t
50 ())
51 (defknown %heap-alien-addr (heap-alien-info) (alien (* t))
52 (flushable movable))
53
54 (defknown make-local-alien (local-alien-info) t
55 ())
56 (defknown note-local-alien-type (local-alien-info t) null
57 ())
58 (defknown local-alien (local-alien-info t) t
59 (flushable))
60 (defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
61 (movable))
62 (defknown %set-local-alien (local-alien-info t t) t
63 ())
64 (defknown %local-alien-addr (local-alien-info t) (alien (* t))
65 (flushable movable))
66 (defknown dispose-local-alien (local-alien-info t) t
67 ())
68
69 (defknown %cast (alien-value alien-type) alien
70 (flushable movable))
71
72 (defknown naturalize (t alien-type) alien
73 (flushable movable))
74 (defknown deport (alien alien-type) t
75 (flushable movable))
76 (defknown extract-alien-value (system-area-pointer index alien-type) t
77 (flushable))
78 (defknown deposit-alien-value (system-area-pointer index alien-type t) t
79 ())
80
81 (defknown alien-funcall (alien-value &rest *) *
82 (any recursive))
83 (defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
84
85
86 ;;;; Cosmetic transforms.
87
88 (deftransform slot ((object slot)
89 ((alien (* t)) symbol))
90 '(slot (deref object) slot))
91
92 (deftransform %set-slot ((object slot value)
93 ((alien (* t)) symbol t))
94 '(%set-slot (deref object) slot value))
95
96 (deftransform %slot-addr ((object slot)
97 ((alien (* t)) symbol))
98 '(%slot-addr (deref object) slot))
99
100
101 ;;;; SLOT support
102
103 (defun find-slot-offset-and-type (alien slot)
104 (unless (constant-continuation-p slot)
105 (give-up (intl:gettext "Slot is not constant, so cannot open code access.")))
106 (let ((type (continuation-type alien)))
107 (unless (alien-type-type-p type)
108 (give-up))
109 (let ((alien-type (alien-type-type-alien-type type)))
110 (unless (alien-record-type-p alien-type)
111 (give-up))
112 (let* ((slot-name (continuation-value slot))
113 (field (find slot-name (alien-record-type-fields alien-type)
114 :key #'alien-record-field-name)))
115 (unless field
116 (abort-transform (intl:gettext "~S doesn't have a slot named ~S") alien slot-name))
117 (values (alien-record-field-offset field)
118 (alien-record-field-type field))))))
119
120 #+nil ;; Shouldn't be necessary.
121 (defoptimizer (slot derive-type) ((alien slot))
122 (block nil
123 (catch 'give-up
124 (multiple-value-bind (slot-offset slot-type)
125 (find-slot-offset-and-type alien slot)
126 (declare (ignore slot-offset))
127 (return (make-alien-type-type slot-type))))
128 *wild-type*))
129
130 (deftransform slot ((alien slot) * * :important t)
131 (multiple-value-bind (slot-offset slot-type)
132 (find-slot-offset-and-type alien slot)
133 `(extract-alien-value (alien-sap alien)
134 ,slot-offset
135 ',slot-type)))
136
137 #+nil ;; ### But what about coersions?
138 (defoptimizer (%set-slot derive-type) ((alien slot value))
139 (block nil
140 (catch 'give-up
141 (multiple-value-bind (slot-offset slot-type)
142 (find-slot-offset-and-type alien slot)
143 (declare (ignore slot-offset))
144 (let ((type (make-alien-type-type slot-type)))
145 (assert-continuation-type value type)
146 (return type))))
147 *wild-type*))
148
149 (deftransform %set-slot ((alien slot value) * * :important t)
150 (multiple-value-bind (slot-offset slot-type)
151 (find-slot-offset-and-type alien slot)
152 `(deposit-alien-value (alien-sap alien)
153 ,slot-offset
154 ',slot-type
155 value)))
156
157 (defoptimizer (%slot-addr derive-type) ((alien slot))
158 (block nil
159 (catch 'give-up
160 (multiple-value-bind (slot-offset slot-type)
161 (find-slot-offset-and-type alien slot)
162 (declare (ignore slot-offset))
163 (return (make-alien-type-type
164 (make-alien-pointer-type :to slot-type)))))
165 *wild-type*))
166
167 (deftransform %slot-addr ((alien slot) * * :important t)
168 (multiple-value-bind (slot-offset slot-type)
169 (find-slot-offset-and-type alien slot)
170 `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset vm:byte-bits))
171 ',(make-alien-pointer-type :to slot-type))))
172
173
174
175 ;;;; DEREF support.
176
177 (defun find-deref-alien-type (alien)
178 (let ((alien-type (continuation-type alien)))
179 (unless (alien-type-type-p alien-type)
180 (give-up))
181 (let ((alien-type (alien-type-type-alien-type alien-type)))
182 (if (alien-type-p alien-type)
183 alien-type
184 (give-up)))))
185
186 (defun find-deref-element-type (alien)
187 (let ((alien-type (find-deref-alien-type alien)))
188 (typecase alien-type
189 (alien-pointer-type
190 (alien-pointer-type-to alien-type))
191 (alien-array-type
192 (alien-array-type-element-type alien-type))
193 (t
194 (give-up)))))
195
196 (defun compute-deref-guts (alien indices)
197 (let ((alien-type (find-deref-alien-type alien)))
198 (typecase alien-type
199 (alien-pointer-type
200 (when (cdr indices)
201 (abort-transform (intl:gettext "Too many indices for pointer deref: ~D")
202 (length indices)))
203 (let ((element-type (alien-pointer-type-to alien-type)))
204 (if indices
205 (let ((bits (alien-type-bits element-type))
206 (alignment (alien-type-alignment element-type)))
207 (unless bits
208 (abort-transform (intl:gettext "Unknown element size.")))
209 (unless alignment
210 (abort-transform (intl:gettext "Unknown element alignment.")))
211 (values '(offset)
212 `(* offset
213 ,(align-offset bits alignment))
214 element-type))
215 (values nil 0 element-type))))
216 (alien-array-type
217 (let* ((element-type (alien-array-type-element-type alien-type))
218 (bits (alien-type-bits element-type))
219 (alignment (alien-type-alignment element-type))
220 (dims (alien-array-type-dimensions alien-type)))
221 (unless (= (length indices) (length dims))
222 (give-up (intl:gettext "Incorrect number of indices.")))
223 (unless bits
224 (give-up (intl:gettext "Element size unknown.")))
225 (unless alignment
226 (give-up (intl:gettext "Element alignment unknown.")))
227 (if (null dims)
228 (values nil 0 element-type)
229 (let* ((arg (gensym))
230 (args (list arg))
231 (offsetexpr arg))
232 (dolist (dim (cdr dims))
233 (let ((arg (gensym)))
234 (push arg args)
235 (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
236 (values (reverse args)
237 `(* ,offsetexpr
238 ,(align-offset bits alignment))
239 element-type)))))
240 (t
241 (abort-transform (intl:gettext "~S not either a pointer or array type.")
242 alien-type)))))
243
244
245 #+nil ;; Shouldn't be necessary.
246 (defoptimizer (deref derive-type) ((alien &rest noise))
247 (declare (ignore noise))
248 (block nil
249 (catch 'give-up
250 (return (make-alien-type-type (find-deref-element-type alien))))
251 *wild-type*))
252
253 (deftransform deref ((alien &rest indices) * * :important t)
254 (multiple-value-bind
255 (indices-args offset-expr element-type)
256 (compute-deref-guts alien indices)
257 `(lambda (alien ,@indices-args)
258 (extract-alien-value (alien-sap alien)
259 ,offset-expr
260 ',element-type))))
261
262 #+nil ;; ### Again, the value might be coerced.
263 (defoptimizer (%set-deref derive-type) ((alien value &rest noise))
264 (declare (ignore noise))
265 (block nil
266 (catch 'give-up
267 (let ((type (make-alien-type-type
268 (make-alien-pointer-type
269 :to (find-deref-element-type alien)))))
270 (assert-continuation-type value type)
271 (return type)))
272 *wild-type*))
273
274 (deftransform %set-deref ((alien value &rest indices) * * :important t)
275 (multiple-value-bind
276 (indices-args offset-expr element-type)
277 (compute-deref-guts alien indices)
278 `(lambda (alien value ,@indices-args)
279 (deposit-alien-value (alien-sap alien)
280 ,offset-expr
281 ',element-type
282 value))))
283
284 (defoptimizer (%deref-addr derive-type) ((alien &rest noise))
285 (declare (ignore noise))
286 (block nil
287 (catch 'give-up
288 (return (make-alien-type-type
289 (make-alien-pointer-type
290 :to (find-deref-element-type alien)))))
291 *wild-type*))
292
293 (deftransform %deref-addr ((alien &rest indices) * * :important t)
294 (multiple-value-bind
295 (indices-args offset-expr element-type)
296 (compute-deref-guts alien indices)
297 `(lambda (alien ,@indices-args)
298 (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr vm:byte-bits))
299 ',(make-alien-pointer-type :to element-type)))))
300
301
302
303 ;;;; Heap Alien Support.
304
305 (defun heap-alien-sap-and-type (info)
306 (unless (constant-continuation-p info)
307 (give-up (intl:gettext "Info not constant; can't open code.")))
308 (let ((info (continuation-value info)))
309 (values (heap-alien-info-sap-form info)
310 (heap-alien-info-type info))))
311
312 #+nil ;; Shouldn't be necessary.
313 (defoptimizer (%heap-alien derive-type) ((info))
314 (block nil
315 (catch 'give-up
316 (multiple-value-bind (sap type)
317 (heap-alien-sap-and-type info)
318 (declare (ignore sap))
319 (return (make-alien-type-type type))))
320 *wild-type*))
321
322 (deftransform %heap-alien ((info) * * :important t)
323 (multiple-value-bind (sap type)
324 (heap-alien-sap-and-type info)
325 `(extract-alien-value ,sap 0 ',type)))
326
327 #+nil ;; ### Again, deposit value might change the type.
328 (defoptimizer (%set-heap-alien derive-type) ((info value))
329 (block nil
330 (catch 'give-up
331 (multiple-value-bind (sap type)
332 (heap-alien-sap-and-type info)
333 (declare (ignore sap))
334 (let ((type (make-alien-type-type type)))
335 (assert-continuation-type value type)
336 (return type))))
337 *wild-type*))
338
339 (deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
340 (multiple-value-bind (sap type)
341 (heap-alien-sap-and-type info)
342 `(deposit-alien-value ,sap 0 ',type value)))
343
344 (defoptimizer (%heap-alien-addr derive-type) ((info))
345 (block nil
346 (catch 'give-up
347 (multiple-value-bind (sap type)
348 (heap-alien-sap-and-type info)
349 (declare (ignore sap))
350 (return (make-alien-type-type (make-alien-pointer-type :to type)))))
351 *wild-type*))
352
353 (deftransform %heap-alien-addr ((info) * * :important t)
354 (multiple-value-bind (sap type)
355 (heap-alien-sap-and-type info)
356 `(%sap-alien ,sap ',type)))
357
358
359 ;;;; Local (stack or register) alien support.
360
361 (deftransform make-local-alien ((info) * * :important t)
362 (unless (constant-continuation-p info)
363 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
364 (let* ((info (continuation-value info))
365 (alien-type (local-alien-info-type info))
366 (bits (alien-type-bits alien-type)))
367 (unless bits
368 (abort-transform (intl:gettext "Unknown size: ~S") (unparse-alien-type alien-type)))
369 (if (local-alien-info-force-to-memory-p info)
370 (if (or (backend-featurep :x86) (backend-featurep :amd64))
371 `(truly-the system-area-pointer
372 (%primitive alloc-alien-stack-space
373 ,(ceiling (alien-type-bits alien-type)
374 vm:byte-bits)))
375 `(truly-the system-area-pointer
376 (%primitive alloc-number-stack-space
377 ,(ceiling (alien-type-bits alien-type)
378 vm:byte-bits))))
379 (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
380 (alien-rep-type (specifier-type alien-rep-type-spec)))
381 (cond ((csubtypep (specifier-type 'system-area-pointer)
382 alien-rep-type)
383 '(int-sap 0))
384 ((ctypep 0 alien-rep-type) 0)
385 ((ctypep 0.0f0 alien-rep-type) 0.0f0)
386 ((ctypep 0.0d0 alien-rep-type) 0.0d0)
387 (t
388 (compiler-error
389 _N"Aliens of type ~S cannot be represented immediately."
390 (unparse-alien-type alien-type))))))))
391
392 (deftransform note-local-alien-type ((info var) * * :important t)
393 (unless (constant-continuation-p info)
394 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
395 (let ((info (continuation-value info)))
396 (unless (local-alien-info-force-to-memory-p info)
397 (let ((var-node (continuation-use var)))
398 (when (ref-p var-node)
399 (propagate-to-refs (ref-leaf var-node)
400 (specifier-type
401 (compute-alien-rep-type
402 (local-alien-info-type info))))))))
403 'nil)
404
405 (deftransform local-alien ((info var) * * :important t)
406 (unless (constant-continuation-p info)
407 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
408 (let* ((info (continuation-value info))
409 (alien-type (local-alien-info-type info)))
410 (if (local-alien-info-force-to-memory-p info)
411 `(extract-alien-value var 0 ',alien-type)
412 `(naturalize var ',alien-type))))
413
414 (deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
415 (unless (constant-continuation-p info)
416 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
417 (let ((info (continuation-value info)))
418 (local-alien-info-force-to-memory-p info)))
419
420 (deftransform %set-local-alien ((info var value) * * :important t)
421 (unless (constant-continuation-p info)
422 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
423 (let* ((info (continuation-value info))
424 (alien-type (local-alien-info-type info)))
425 (if (local-alien-info-force-to-memory-p info)
426 `(deposit-alien-value var 0 ',alien-type value)
427 '(error (intl:gettext "This should be dead-code eleminated.")))))
428
429 (defoptimizer (%local-alien-addr derive-type) ((info var))
430 (if (constant-continuation-p info)
431 (let* ((info (continuation-value info))
432 (alien-type (local-alien-info-type info)))
433 (make-alien-type-type (make-alien-pointer-type :to alien-type)))
434 *wild-type*))
435
436 (deftransform %local-alien-addr ((info var) * * :important t)
437 (unless (constant-continuation-p info)
438 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
439 (let* ((info (continuation-value info))
440 (alien-type (local-alien-info-type info)))
441 (if (local-alien-info-force-to-memory-p info)
442 `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
443 (error (intl:gettext "This shouldn't happen.")))))
444
445 (deftransform dispose-local-alien ((info var) * * :important t)
446 (unless (constant-continuation-p info)
447 (abort-transform (intl:gettext "Local Alien Info isn't constant?")))
448 (let* ((info (continuation-value info))
449 (alien-type (local-alien-info-type info)))
450 (if (local-alien-info-force-to-memory-p info)
451 (if (or (backend-featurep :x86) (backend-featurep :amd64))
452 `(%primitive dealloc-alien-stack-space
453 ,(ceiling (alien-type-bits alien-type)
454 vm:byte-bits))
455 `(%primitive dealloc-number-stack-space
456 ,(ceiling (alien-type-bits alien-type)
457 vm:byte-bits)))
458 nil)))
459
460
461 ;;;; %CAST
462
463 (defoptimizer (%cast derive-type) ((alien type))
464 (or (when (constant-continuation-p type)
465 (let ((alien-type (continuation-value type)))
466 (when (alien-type-p alien-type)
467 (make-alien-type-type alien-type))))
468 *wild-type*))
469
470 (deftransform %cast ((alien target-type) * * :important t)
471 (unless (constant-continuation-p target-type)
472 (give-up (intl:gettext "Alien type not constant; cannot open code.")))
473 (let ((target-type (continuation-value target-type)))
474 (cond ((or (alien-pointer-type-p target-type)
475 (alien-array-type-p target-type)
476 (alien-function-type-p target-type))
477 `(naturalize (alien-sap alien) ',target-type))
478 (t
479 (abort-transform (intl:gettext "Cannot cast to alien type ~S") target-type)))))
480
481
482 ;;;; alien-sap, %sap-alien, %addr, etc
483
484 (deftransform alien-sap ((alien) * * :important t)
485 (let ((alien-node (continuation-use alien)))
486 (typecase alien-node
487 (combination
488 (extract-function-args alien '%sap-alien 2)
489 '(lambda (sap type)
490 (declare (ignore type))
491 sap))
492 (t
493 (give-up)))))
494
495 (defoptimizer (%sap-alien derive-type) ((sap type))
496 (declare (ignore sap))
497 (if (constant-continuation-p type)
498 (make-alien-type-type (continuation-value type))
499 *wild-type*))
500
501 (deftransform %sap-alien ((sap type) * * :important t)
502 (give-up (intl:gettext "Could not optimize away %SAP-ALIEN: forced to do runtime ~@
503 allocation of alien-value structure.")))
504
505
506
507 ;;;; Extract/deposit magic
508
509 (eval-when (compile eval)
510 (defmacro compiler-error-if-loses (form)
511 `(handler-case
512 ,form
513 (error (condition)
514 (compiler-error "~A" condition)))))
515
516 (deftransform naturalize ((object type) * * :important t)
517 (unless (constant-continuation-p type)
518 (give-up (intl:gettext "Type not constant at compile time; can't open code.")))
519 (compiler-error-if-loses
520 (compute-naturalize-lambda (continuation-value type))))
521
522 (deftransform deport ((alien type) * * :important t)
523 (unless (constant-continuation-p type)
524 (give-up (intl:gettext "Type not constant at compile time; can't open code.")))
525 (compiler-error-if-loses
526 (compute-deport-lambda (continuation-value type))))
527
528 (deftransform extract-alien-value ((sap offset type) * * :important t)
529 (unless (constant-continuation-p type)
530 (give-up (intl:gettext "Type not constant at compile time; can't open code.")))
531 (compiler-error-if-loses
532 (compute-extract-lambda (continuation-value type))))
533
534 (deftransform deposit-alien-value ((sap offset type value) * * :important t)
535 (unless (constant-continuation-p type)
536 (give-up (intl:gettext "Type not constant at compile time; can't open code.")))
537 (compiler-error-if-loses
538 (compute-deposit-lambda (continuation-value type))))
539
540
541 ;;;; Hack to clean up divisions.
542
543 (defun count-low-order-zeros (thing)
544 (typecase thing
545 (continuation
546 (if (constant-continuation-p thing)
547 (count-low-order-zeros (continuation-value thing))
548 (count-low-order-zeros (continuation-use thing))))
549 (combination
550 (case (continuation-function-name (combination-fun thing))
551 ((+ -)
552 (let ((min most-positive-fixnum)
553 (itype (specifier-type 'integer)))
554 (dolist (arg (combination-args thing) min)
555 (if (csubtypep (continuation-type arg) itype)
556 (setf min (min min (count-low-order-zeros arg)))
557 (return 0)))))
558 (*
559 (let ((result 0)
560 (itype (specifier-type 'integer)))
561 (dolist (arg (combination-args thing) result)
562 (if (csubtypep (continuation-type arg) itype)
563 (setf result (+ result (count-low-order-zeros arg)))
564 (return 0)))))
565 (ash
566 (let ((args (combination-args thing)))
567 (if (= (length args) 2)
568 (let ((amount (second args)))
569 (if (constant-continuation-p amount)
570 (max (+ (count-low-order-zeros (first args))
571 (continuation-value amount))
572 0)
573 0))
574 0)))
575 (t
576 0)))
577 (integer
578 (if (zerop thing)
579 most-positive-fixnum
580 (do ((result 0 (1+ result))
581 (num thing (ash num -1)))
582 ((logbitp 0 num) result))))
583 (t
584 0)))
585
586 (deftransform / ((numerator denominator) (integer integer))
587 (unless (constant-continuation-p denominator)
588 (give-up))
589 (let* ((denominator (continuation-value denominator))
590 (bits (1- (integer-length denominator))))
591 (unless (and (plusp denominator)
592 (= (ash 1 bits) denominator))
593 (give-up))
594 (let ((alignment (count-low-order-zeros numerator)))
595 (unless (>= alignment bits)
596 (give-up))
597 `(ash numerator ,(- bits)))))
598
599 (deftransform ash ((value amount))
600 (let ((value-node (continuation-use value)))
601 (unless (and (combination-p value-node)
602 (eq (continuation-function-name (combination-fun value-node))
603 'ash))
604 (give-up))
605 (let ((inside-args (combination-args value-node)))
606 (unless (= (length inside-args) 2)
607 (give-up))
608 (let ((inside-amount (second inside-args)))
609 (unless (and (constant-continuation-p inside-amount)
610 (not (minusp (continuation-value inside-amount))))
611 (give-up)))))
612 (extract-function-args value 'ash 2)
613 '(lambda (value amount1 amount2)
614 (ash value (+ amount1 amount2))))
615
616
617 ;;;; ALIEN-FUNCALL support.
618
619 (deftransform alien-funcall ((function &rest args)
620 ((alien (* t)) &rest *) *
621 :important t)
622 (let ((names (loop repeat (length args) collect (gensym))))
623 `(lambda (function ,@names)
624 (alien-funcall (deref function) ,@names))))
625
626 (deftransform alien-funcall ((function &rest args) * * :important t)
627 (let ((type (continuation-type function)))
628 (unless (alien-type-type-p type)
629 (give-up (intl:gettext "Can't tell function type at compile time.")))
630 (let ((alien-type (alien-type-type-alien-type type)))
631 (unless (alien-function-type-p alien-type)
632 (give-up))
633 (let ((arg-types (alien-function-type-arg-types alien-type)))
634 (unless (= (length args) (length arg-types))
635 (abort-transform (intl:gettext "Wrong number of arguments. Expected ~D, got ~D.")
636 (length arg-types) (length args)))
637 (collect ((params) (deports))
638 (dolist (arg-type arg-types)
639 (let ((param (gensym)))
640 (params param)
641 (deports `(deport ,param ',arg-type))))
642 (let ((return-type (alien-function-type-result-type alien-type))
643 (body `(%alien-funcall (deport function ',alien-type)
644 ',alien-type
645 ,@(deports))))
646 (if (alien-values-type-p return-type)
647 (collect ((temps) (results))
648 (dolist (type (alien-values-type-values return-type))
649 (let ((temp (gensym)))
650 (temps temp)
651 (results `(naturalize ,temp ',type))))
652 (setf body
653 `(multiple-value-bind
654 ,(temps)
655 ,body
656 (values ,@(results)))))
657 (setf body `(naturalize ,body ',return-type)))
658 `(lambda (function ,@(params))
659 ,body)))))))
660
661 (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
662 (declare (ignore function args))
663 (unless (constant-continuation-p type)
664 (error (intl:gettext "Something is broken.")))
665 (let ((type (continuation-value type)))
666 (unless (alien-function-type-p type)
667 (error (intl:gettext "Something is broken.")))
668 (specifier-type
669 (compute-alien-rep-type
670 (alien-function-type-result-type type)))))
671
672 (defoptimizer (%alien-funcall ltn-annotate)
673 ((function type &rest args) node policy)
674 (setf (basic-combination-info node) :funny)
675 (setf (node-tail-p node) nil)
676 (annotate-ordinary-continuation function policy)
677 (dolist (arg args)
678 (annotate-ordinary-continuation arg policy)))
679
680 (defoptimizer (%alien-funcall ir2-convert)
681 ((function type &rest args) call block)
682 (let ((type (if (constant-continuation-p type)
683 (continuation-value type)
684 (error (intl:gettext "Something is broken."))))
685 (cont (node-cont call))
686 (args args))
687 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
688 (make-call-out-tns type)
689 (vop alloc-number-stack-space call block stack-frame-size nsp)
690 (dolist (tn arg-tns)
691 ;; On PPC, TN might be a list. This is used to indicate
692 ;; something special needs to happen. See below.
693 ;;
694 ;; FIXME: We should implement something better than this.
695 (let* ((first-tn (if (listp tn) (car tn) tn))
696 (arg (pop args))
697 (sc (tn-sc first-tn))
698 (scn (sc-number sc))
699 (temp-tn (make-representation-tn (tn-primitive-type first-tn) scn))
700 (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
701 (assert arg)
702 (assert (= (length move-arg-vops) 1) ()
703 (intl:gettext "No unique move-arg-vop for moves in SC ~S.")
704 (sc-name sc))
705
706 (emit-move call block (continuation-tn call block arg) temp-tn)
707 (emit-move-arg-template call block (first move-arg-vops)
708 temp-tn nsp first-tn)
709 #+(and ppc darwin)
710 (when (listp tn)
711 ;; This means that we have a float arg that we need to
712 ;; also copy to some int regs. The list contains the TN
713 ;; for the float as well as the TNs to use for the int
714 ;; arg.
715 (destructuring-bind (float-tn i1-tn &optional i2-tn)
716 tn
717 (if i2-tn
718 (vop ppc::move-double-to-int-arg call block
719 float-tn i1-tn i2-tn)
720 (vop ppc::move-single-to-int-arg call block
721 float-tn i1-tn))))))
722 (assert (null args))
723 (unless (listp result-tns)
724 (setf result-tns (list result-tns)))
725 (let ((arg-tns (flatten-list arg-tns)))
726 (vop* call-out call block
727 ((continuation-tn call block function)
728 (reference-tn-list arg-tns nil))
729 ((reference-tn-list result-tns t))))
730 (vop dealloc-number-stack-space call block stack-frame-size)
731 (move-continuation-result call block result-tns cont))))

  ViewVC Help
Powered by ViewVC 1.1.5