1 ;;;; transforms and other stuff used to compile ALIEN 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.
16 (defknown %sap-alien
(system-area-pointer alien-type
) alien-value
18 (defknown alien-sap
(alien-value) system-area-pointer
21 (defknown slot
(alien-value symbol
) t
22 (flushable recursive
))
23 (defknown %set-slot
(alien-value symbol t
) t
25 (defknown %slot-addr
(alien-value symbol
) (alien (* t
))
26 (flushable movable recursive
))
28 (defknown deref
(alien-value &rest index
) t
30 (defknown %set-deref
(alien-value t
&rest index
) t
32 (defknown %deref-addr
(alien-value &rest index
) (alien (* t
))
35 (defknown %heap-alien
(heap-alien-info) t
37 (defknown %set-heap-alien
(heap-alien-info t
) t
39 (defknown %heap-alien-addr
(heap-alien-info) (alien (* t
))
42 (defknown make-local-alien
(local-alien-info) t
44 (defknown note-local-alien-type
(local-alien-info t
) null
46 (defknown local-alien
(local-alien-info t
) t
48 (defknown %local-alien-forced-to-memory-p
(local-alien-info) (member t nil
)
50 (defknown %set-local-alien
(local-alien-info t t
) t
52 (defknown %local-alien-addr
(local-alien-info t
) (alien (* t
))
54 (defknown dispose-local-alien
(local-alien-info t
) t
57 (defknown %cast
(alien-value alien-type
) alien
60 (defknown naturalize
(t alien-type
) alien
62 (defknown deport
(alien alien-type
) t
64 (defknown deport-alloc
(alien alien-type
) t
66 (defknown extract-alien-value
(system-area-pointer unsigned-byte alien-type
) t
68 (defknown deposit-alien-value
(system-area-pointer unsigned-byte alien-type t
) t
71 (defknown alien-funcall
(alien-value &rest
*) *
74 ;;;; cosmetic transforms
76 (deftransform slot
((object slot
)
77 ((alien (* t
)) symbol
))
78 '(slot (deref object
) slot
))
80 (deftransform %set-slot
((object slot value
)
81 ((alien (* t
)) symbol t
))
82 '(%set-slot
(deref object
) slot value
))
84 (deftransform %slot-addr
((object slot
)
85 ((alien (* t
)) symbol
))
86 '(%slot-addr
(deref object
) slot
))
90 (defun find-slot-offset-and-type (alien slot
)
91 (unless (constant-lvar-p slot
)
92 (give-up-ir1-transform
93 "The slot is not constant, so access cannot be open coded."))
94 (let ((type (lvar-type alien
)))
95 (unless (alien-type-type-p type
)
96 (give-up-ir1-transform))
97 (let ((alien-type (alien-type-type-alien-type type
)))
98 (unless (alien-record-type-p alien-type
)
99 (give-up-ir1-transform))
100 (let* ((slot-name (lvar-value slot
))
101 (field (find slot-name
(alien-record-type-fields alien-type
)
102 :key
#'alien-record-field-name
)))
104 (abort-ir1-transform "~S doesn't have a slot named ~S"
107 (values (alien-record-field-offset field
)
108 (alien-record-field-type field
))))))
110 #+nil
;; Shouldn't be necessary.
111 (defoptimizer (slot derive-type
) ((alien slot
))
113 (catch 'give-up-ir1-transform
114 (multiple-value-bind (slot-offset slot-type
)
115 (find-slot-offset-and-type alien slot
)
116 (declare (ignore slot-offset
))
117 (return (make-alien-type-type slot-type
))))
120 (deftransform slot
((alien slot
) * * :important t
)
121 (multiple-value-bind (slot-offset slot-type
)
122 (find-slot-offset-and-type alien slot
)
123 `(extract-alien-value (alien-sap alien
)
127 #+nil
;; ### But what about coercions?
128 (defoptimizer (%set-slot derive-type
) ((alien slot value
))
130 (catch 'give-up-ir1-transform
131 (multiple-value-bind (slot-offset slot-type
)
132 (find-slot-offset-and-type alien slot
)
133 (declare (ignore slot-offset
))
134 (let ((type (make-alien-type-type slot-type
)))
135 (assert-lvar-type value type
)
139 (deftransform %set-slot
((alien slot value
) * * :important t
)
140 (multiple-value-bind (slot-offset slot-type
)
141 (find-slot-offset-and-type alien slot
)
142 `(deposit-alien-value (alien-sap alien
)
147 (defoptimizer (%slot-addr derive-type
) ((alien slot
))
149 (catch 'give-up-ir1-transform
150 (multiple-value-bind (slot-offset slot-type
)
151 (find-slot-offset-and-type alien slot
)
152 (declare (ignore slot-offset
))
153 (return (make-alien-type-type
154 (make-alien-pointer-type :to slot-type
)))))
157 (deftransform %slot-addr
((alien slot
) * * :important t
)
158 (multiple-value-bind (slot-offset slot-type
)
159 (find-slot-offset-and-type alien slot
)
160 (/noshow
"in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
161 `(%sap-alien
(sap+ (alien-sap alien
) (/ ,slot-offset sb
!vm
:n-byte-bits
))
162 ',(make-alien-pointer-type :to slot-type
))))
166 (defun find-deref-alien-type (alien)
167 (let ((alien-type (lvar-type alien
)))
168 (unless (alien-type-type-p alien-type
)
169 (give-up-ir1-transform))
170 (let ((alien-type (alien-type-type-alien-type alien-type
)))
171 (if (alien-type-p alien-type
)
173 (give-up-ir1-transform)))))
175 (defun find-deref-element-type (alien)
176 (let ((alien-type (find-deref-alien-type alien
)))
179 (alien-pointer-type-to alien-type
))
181 (alien-array-type-element-type alien-type
))
183 (give-up-ir1-transform)))))
185 (defun compute-deref-guts (alien indices
)
186 (let ((alien-type (find-deref-alien-type alien
)))
190 (abort-ir1-transform "too many indices for pointer deref: ~W"
192 (let ((element-type (alien-pointer-type-to alien-type
)))
194 (let ((bits (alien-type-bits element-type
))
195 (alignment (alien-type-alignment element-type
)))
197 (abort-ir1-transform "unknown element size"))
199 (abort-ir1-transform "unknown element alignment"))
202 ,(align-offset bits alignment
))
204 (values nil
0 element-type
))))
206 (let* ((element-type (alien-array-type-element-type alien-type
))
207 (bits (alien-type-bits element-type
))
208 (alignment (alien-type-alignment element-type
))
209 (dims (alien-array-type-dimensions alien-type
)))
210 (unless (= (length indices
) (length dims
))
211 (give-up-ir1-transform "incorrect number of indices"))
213 (give-up-ir1-transform "Element size is unknown."))
215 (give-up-ir1-transform "Element alignment is unknown."))
217 (values nil
0 element-type
)
218 (let* ((arg (gensym))
221 (dolist (dim (cdr dims
))
222 (let ((arg (gensym)))
224 (setf offsetexpr
`(+ (* ,offsetexpr
,dim
) ,arg
))))
225 (values (reverse args
)
227 ,(align-offset bits alignment
))
230 (abort-ir1-transform "~S not either a pointer or array type."
233 #+nil
;; Shouldn't be necessary.
234 (defoptimizer (deref derive-type
) ((alien &rest noise
))
235 (declare (ignore noise
))
237 (catch 'give-up-ir1-transform
238 (return (make-alien-type-type (find-deref-element-type alien
))))
241 (deftransform deref
((alien &rest indices
) * * :important t
)
242 (multiple-value-bind (indices-args offset-expr element-type
)
243 (compute-deref-guts alien indices
)
244 `(lambda (alien ,@indices-args
)
245 (extract-alien-value (alien-sap alien
)
249 #+nil
;; ### Again, the value might be coerced.
250 (defoptimizer (%set-deref derive-type
) ((alien value
&rest noise
))
251 (declare (ignore noise
))
253 (catch 'give-up-ir1-transform
254 (let ((type (make-alien-type-type
255 (make-alien-pointer-type
256 :to
(find-deref-element-type alien
)))))
257 (assert-lvar-type value type
)
261 (deftransform %set-deref
((alien value
&rest indices
) * * :important t
)
262 (multiple-value-bind (indices-args offset-expr element-type
)
263 (compute-deref-guts alien indices
)
264 `(lambda (alien value
,@indices-args
)
265 (deposit-alien-value (alien-sap alien
)
270 (defoptimizer (%deref-addr derive-type
) ((alien &rest noise
))
271 (declare (ignore noise
))
273 (catch 'give-up-ir1-transform
274 (return (make-alien-type-type
275 (make-alien-pointer-type
276 :to
(find-deref-element-type alien
)))))
279 (deftransform %deref-addr
((alien &rest indices
) * * :important t
)
280 (multiple-value-bind (indices-args offset-expr element-type
)
281 (compute-deref-guts alien indices
)
282 (/noshow
"in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
283 `(lambda (alien ,@indices-args
)
284 (%sap-alien
(sap+ (alien-sap alien
) (/ ,offset-expr sb
!vm
:n-byte-bits
))
285 ',(make-alien-pointer-type :to element-type
)))))
287 ;;;; support for aliens on the heap
289 (defun heap-alien-sap-and-type (info)
290 (unless (constant-lvar-p info
)
291 (give-up-ir1-transform "info not constant; can't open code"))
292 (let ((info (lvar-value info
)))
293 (values (heap-alien-info-sap-form info
)
294 (heap-alien-info-type info
))))
296 #+nil
; shouldn't be necessary
297 (defoptimizer (%heap-alien derive-type
) ((info))
300 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
301 (declare (ignore sap
))
302 (return (make-alien-type-type type
))))
305 (deftransform %heap-alien
((info) * * :important t
)
306 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
307 `(extract-alien-value ,sap
0 ',type
)))
309 #+nil
;; ### Again, deposit value might change the type.
310 (defoptimizer (%set-heap-alien derive-type
) ((info value
))
312 (catch 'give-up-ir1-transform
313 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
314 (declare (ignore sap
))
315 (let ((type (make-alien-type-type type
)))
316 (assert-lvar-type value type
)
320 (deftransform %set-heap-alien
((info value
) (heap-alien-info *) * :important t
)
321 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
322 `(deposit-alien-value ,sap
0 ',type value
)))
324 (defoptimizer (%heap-alien-addr derive-type
) ((info))
326 (catch 'give-up-ir1-transform
327 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
328 (declare (ignore sap
))
329 (return (make-alien-type-type (make-alien-pointer-type :to type
)))))
332 (deftransform %heap-alien-addr
((info) * * :important t
)
333 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
334 (/noshow
"in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
335 `(%sap-alien
,sap
',(make-alien-pointer-type :to type
))))
338 ;;;; support for local (stack or register) aliens
340 (deftransform make-local-alien
((info) * * :important t
)
341 (unless (constant-lvar-p info
)
342 (abort-ir1-transform "Local alien info isn't constant?"))
343 (let* ((info (lvar-value info
))
344 (alien-type (local-alien-info-type info
))
345 (bits (alien-type-bits alien-type
)))
347 (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type
)))
348 (/noshow
"in DEFTRANSFORM MAKE-LOCAL-ALIEN" info
)
349 (/noshow
(local-alien-info-force-to-memory-p info
))
350 (/noshow alien-type
(unparse-alien-type alien-type
) (alien-type-bits alien-type
))
351 (if (local-alien-info-force-to-memory-p info
)
353 `(truly-the system-area-pointer
354 (%primitive alloc-alien-stack-space
355 ,(ceiling (alien-type-bits alien-type
)
358 `(truly-the system-area-pointer
359 (%primitive alloc-number-stack-space
360 ,(ceiling (alien-type-bits alien-type
)
362 (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type
))
363 (alien-rep-type (specifier-type alien-rep-type-spec
)))
364 (cond ((csubtypep (specifier-type 'system-area-pointer
)
367 ((ctypep 0 alien-rep-type
) 0)
368 ((ctypep 0.0f0 alien-rep-type
) 0.0f0
)
369 ((ctypep 0.0d0 alien-rep-type
) 0.0d0
)
372 "Aliens of type ~S cannot be represented immediately."
373 (unparse-alien-type alien-type
))))))))
375 (deftransform note-local-alien-type
((info var
) * * :important t
)
376 ;; FIXME: This test and error occur about a zillion times. They
377 ;; could be factored into a function.
378 (unless (constant-lvar-p info
)
379 (abort-ir1-transform "Local alien info isn't constant?"))
380 (let ((info (lvar-value info
)))
381 (/noshow
"in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info
)
382 (/noshow
(local-alien-info-force-to-memory-p info
))
383 (unless (local-alien-info-force-to-memory-p info
)
384 (let ((var-node (lvar-uses var
)))
385 (/noshow var-node
(ref-p var-node
))
386 (when (ref-p var-node
)
387 (propagate-to-refs (ref-leaf var-node
)
389 (compute-alien-rep-type
390 (local-alien-info-type info
))))))))
393 (deftransform local-alien
((info var
) * * :important t
)
394 (unless (constant-lvar-p info
)
395 (abort-ir1-transform "Local alien info isn't constant?"))
396 (let* ((info (lvar-value info
))
397 (alien-type (local-alien-info-type info
)))
398 (/noshow
"in DEFTRANSFORM LOCAL-ALIEN" info alien-type
)
399 (/noshow
(local-alien-info-force-to-memory-p info
))
400 (if (local-alien-info-force-to-memory-p info
)
401 `(extract-alien-value var
0 ',alien-type
)
402 `(naturalize var
',alien-type
))))
404 (deftransform %local-alien-forced-to-memory-p
((info) * * :important t
)
405 (unless (constant-lvar-p info
)
406 (abort-ir1-transform "Local alien info isn't constant?"))
407 (let ((info (lvar-value info
)))
408 (local-alien-info-force-to-memory-p info
)))
410 (deftransform %set-local-alien
((info var value
) * * :important t
)
411 (unless (constant-lvar-p info
)
412 (abort-ir1-transform "Local alien info isn't constant?"))
413 (let* ((info (lvar-value info
))
414 (alien-type (local-alien-info-type info
)))
415 (if (local-alien-info-force-to-memory-p info
)
416 `(deposit-alien-value var
0 ',alien-type value
)
417 '(error "This should be eliminated as dead code."))))
419 (defoptimizer (%local-alien-addr derive-type
) ((info var
))
420 (if (constant-lvar-p info
)
421 (let* ((info (lvar-value info
))
422 (alien-type (local-alien-info-type info
)))
423 (make-alien-type-type (make-alien-pointer-type :to alien-type
)))
426 (deftransform %local-alien-addr
((info var
) * * :important t
)
427 (unless (constant-lvar-p info
)
428 (abort-ir1-transform "Local alien info isn't constant?"))
429 (let* ((info (lvar-value info
))
430 (alien-type (local-alien-info-type info
)))
431 (/noshow
"in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
432 (if (local-alien-info-force-to-memory-p info
)
433 `(%sap-alien var
',(make-alien-pointer-type :to alien-type
))
434 (error "This shouldn't happen."))))
436 (deftransform dispose-local-alien
((info var
) * * :important t
)
437 (unless (constant-lvar-p info
)
438 (abort-ir1-transform "Local alien info isn't constant?"))
439 (let* ((info (lvar-value info
))
440 (alien-type (local-alien-info-type info
)))
441 (if (local-alien-info-force-to-memory-p info
)
442 #!+(or x86 x86-64
) `(%primitive dealloc-alien-stack-space
443 ,(ceiling (alien-type-bits alien-type
)
445 #!-
(or x86 x86-64
) `(%primitive dealloc-number-stack-space
446 ,(ceiling (alien-type-bits alien-type
)
452 (defoptimizer (%cast derive-type
) ((alien type
))
453 (or (when (constant-lvar-p type
)
454 (let ((alien-type (lvar-value type
)))
455 (when (alien-type-p alien-type
)
456 (make-alien-type-type alien-type
))))
459 (deftransform %cast
((alien target-type
) * * :important t
)
460 (unless (constant-lvar-p target-type
)
461 (give-up-ir1-transform
462 "The alien type is not constant, so access cannot be open coded."))
463 (let ((target-type (lvar-value target-type
)))
464 (cond ((or (alien-pointer-type-p target-type
)
465 (alien-array-type-p target-type
)
466 (alien-fun-type-p target-type
))
467 `(naturalize (alien-sap alien
) ',target-type
))
469 (abort-ir1-transform "cannot cast to alien type ~S" target-type
)))))
471 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
473 (deftransform alien-sap
((alien) * * :important t
)
474 (let ((alien-node (lvar-uses alien
)))
477 (splice-fun-args alien
'%sap-alien
2)
479 (declare (ignore type
))
482 (give-up-ir1-transform)))))
484 (defoptimizer (%sap-alien derive-type
) ((sap type
))
485 (declare (ignore sap
))
486 (if (constant-lvar-p type
)
487 (make-alien-type-type (lvar-value type
))
490 (deftransform %sap-alien
((sap type
) * * :important t
)
491 (give-up-ir1-transform
492 ;; FIXME: The hardcoded newline here causes more-than-usually
493 ;; screwed-up formatting of the optimization note output.
494 "could not optimize away %SAP-ALIEN: forced to do runtime ~@
495 allocation of alien-value structure"))
497 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
499 (flet ((%computed-lambda
(compute-lambda type
)
500 (declare (type function compute-lambda
))
501 (unless (constant-lvar-p type
)
502 (give-up-ir1-transform
503 "The type is not constant at compile time; can't open code."))
505 (let ((result (funcall compute-lambda
(lvar-value type
))))
506 (/noshow
"in %COMPUTED-LAMBDA" (lvar-value type
) result
)
509 (compiler-error "~A" condition
)))))
510 (deftransform naturalize
((object type
) * * :important t
)
511 (%computed-lambda
#'compute-naturalize-lambda type
))
512 (deftransform deport
((alien type
) * * :important t
)
513 (%computed-lambda
#'compute-deport-lambda type
))
514 (deftransform deport-alloc
((alien type
) * * :important t
)
515 (%computed-lambda
#'compute-deport-alloc-lambda type
))
516 (deftransform extract-alien-value
((sap offset type
) * * :important t
)
517 (%computed-lambda
#'compute-extract-lambda type
))
518 (deftransform deposit-alien-value
((sap offset type value
) * * :important t
)
519 (%computed-lambda
#'compute-deposit-lambda type
)))
521 ;;;; a hack to clean up divisions
523 (defun count-low-order-zeros (thing)
526 (if (constant-lvar-p thing
)
527 (count-low-order-zeros (lvar-value thing
))
528 (count-low-order-zeros (lvar-uses thing
))))
530 (case (let ((name (lvar-fun-name (combination-fun thing
))))
531 (or (modular-version-info name
:untagged nil
) name
))
533 (let ((min most-positive-fixnum
)
534 (itype (specifier-type 'integer
)))
535 (dolist (arg (combination-args thing
) min
)
536 (if (csubtypep (lvar-type arg
) itype
)
537 (setf min
(min min
(count-low-order-zeros arg
)))
541 (itype (specifier-type 'integer
)))
542 (dolist (arg (combination-args thing
) result
)
543 (if (csubtypep (lvar-type arg
) itype
)
544 (setf result
(+ result
(count-low-order-zeros arg
)))
547 (let ((args (combination-args thing
)))
548 (if (= (length args
) 2)
549 (let ((amount (second args
)))
550 (if (constant-lvar-p amount
)
551 (max (+ (count-low-order-zeros (first args
))
561 (do ((result 0 (1+ result
))
562 (num thing
(ash num -
1)))
563 ((logbitp 0 num
) result
))))
565 (count-low-order-zeros (cast-value thing
)))
569 (deftransform / ((numerator denominator
) (integer integer
))
570 "convert x/2^k to shift"
571 (unless (constant-lvar-p denominator
)
572 (give-up-ir1-transform))
573 (let* ((denominator (lvar-value denominator
))
574 (bits (1- (integer-length denominator
))))
575 (unless (and (> denominator
0) (= (ash 1 bits
) denominator
))
576 (give-up-ir1-transform))
577 (let ((alignment (count-low-order-zeros numerator
)))
578 (unless (>= alignment bits
)
579 (give-up-ir1-transform))
580 `(ash numerator
,(- bits
)))))
582 (deftransform ash
((value amount
))
583 (let ((value-node (lvar-uses value
)))
584 (unless (combination-p value-node
)
585 (give-up-ir1-transform))
586 (let ((inside-fun-name (lvar-fun-name (combination-fun value-node
))))
587 (multiple-value-bind (prototype width
)
588 (modular-version-info inside-fun-name
:untagged nil
)
589 (unless (eq (or prototype inside-fun-name
) 'ash
)
590 (give-up-ir1-transform))
591 (when (and width
(not (constant-lvar-p amount
)))
592 (give-up-ir1-transform))
593 (let ((inside-args (combination-args value-node
)))
594 (unless (= (length inside-args
) 2)
595 (give-up-ir1-transform))
596 (let ((inside-amount (second inside-args
)))
597 (unless (and (constant-lvar-p inside-amount
)
598 (not (minusp (lvar-value inside-amount
))))
599 (give-up-ir1-transform)))
600 (splice-fun-args value inside-fun-name
2)
602 `(lambda (value amount1 amount2
)
603 (logand (ash value
(+ amount1 amount2
))
604 ,(1- (ash 1 (+ width
(lvar-value amount
))))))
605 `(lambda (value amount1 amount2
)
606 (ash value
(+ amount1 amount2
)))))))))
608 ;;;; ALIEN-FUNCALL support
610 (deftransform alien-funcall
((function &rest args
)
611 ((alien (* t
)) &rest
*) *
613 (let ((names (make-gensym-list (length args
))))
614 (/noshow
"entering first DEFTRANSFORM ALIEN-FUNCALL" function args
)
615 `(lambda (function ,@names
)
616 (alien-funcall (deref function
) ,@names
))))
618 (deftransform alien-funcall
((function &rest args
) * * :important t
)
619 (let ((type (lvar-type function
)))
620 (unless (alien-type-type-p type
)
621 (give-up-ir1-transform "can't tell function type at compile time"))
622 (/noshow
"entering second DEFTRANSFORM ALIEN-FUNCALL" function
)
623 (let ((alien-type (alien-type-type-alien-type type
)))
624 (unless (alien-fun-type-p alien-type
)
625 (give-up-ir1-transform))
626 (let ((arg-types (alien-fun-type-arg-types alien-type
)))
627 (unless (= (length args
) (length arg-types
))
629 "wrong number of arguments; expected ~W, got ~W"
632 (collect ((params) (deports))
633 (dolist (arg-type arg-types
)
634 (let ((param (gensym)))
636 (deports `(deport ,param
',arg-type
))))
637 ;; Build BODY from the inside out.
638 (let ((return-type (alien-fun-type-result-type alien-type
))
639 ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
640 ;; to them) and do the call.
641 (body `(%alien-funcall
(deport function
',alien-type
)
644 ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
645 ;; the SAPs are taken for won't be moved by the GC. (If
646 ;; needed: some alien types won't need it).
647 (setf body
`(maybe-with-pinned-objects ,(params) ,arg-types
649 ;; Around that handle any memory allocation that's needed.
650 ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
651 ;; identity operation, but for example for deporting a
652 ;; Unicode string we need to convert the string into an
653 ;; octet array. This step needs to be done before the pinning
654 ;; to ensure we pin the right objects, so it can't be combined
655 ;; with the deporting.
657 (loop for param in
(params)
658 for arg-type in arg-types
660 `(let ((,param
(deport-alloc ,param
',arg-type
)))
662 (if (alien-values-type-p return-type
)
663 (collect ((temps) (results))
664 (dolist (type (alien-values-type-values return-type
))
665 (let ((temp (gensym)))
667 (results `(naturalize ,temp
',type
))))
669 `(multiple-value-bind ,(temps) ,body
670 (values ,@(results)))))
671 (setf body
`(naturalize ,body
',return-type
)))
672 (/noshow
"returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body
)
673 `(lambda (function ,@(params))
676 (defoptimizer (%alien-funcall derive-type
) ((function type
&rest args
))
677 (declare (ignore function args
))
678 (unless (constant-lvar-p type
)
679 (error "Something is broken."))
680 (let ((type (lvar-value type
)))
681 (unless (alien-fun-type-p type
)
682 (error "Something is broken."))
683 (values-specifier-type
684 (compute-alien-rep-type
685 (alien-fun-type-result-type type
)))))
687 (defoptimizer (%alien-funcall ltn-annotate
)
688 ((function type
&rest args
) node ltn-policy
)
689 (setf (basic-combination-info node
) :funny
)
690 (setf (node-tail-p node
) nil
)
691 (annotate-ordinary-lvar function
)
693 (annotate-ordinary-lvar arg
)))
695 ;;; We support both the stdcall and cdecl calling conventions on win32 by
696 ;;; resetting ESP after the foreign function returns. This way it works
697 ;;; correctly whether the party that is supposed to pop arguments from
698 ;;; the stack is the caller (cdecl) or the callee (stdcall).
699 (defoptimizer (%alien-funcall ir2-convert
)
700 ((function type
&rest args
) call block
)
701 (let ((type (if (constant-lvar-p type
)
703 (error "Something is broken.")))
704 (lvar (node-lvar call
))
707 (stack-pointer (make-stack-pointer-tn)))
708 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns
)
709 (make-call-out-tns type
)
712 (vop set-fpu-word-for-c call block
)
713 (vop current-stack-pointer call block stack-pointer
))
714 (vop alloc-number-stack-space call block stack-frame-size nsp
)
716 ;; On PPC, TN might be a list. This is used to indicate
717 ;; something special needs to happen. See below.
719 ;; FIXME: We should implement something better than this.
720 (let* ((first-tn (if (listp tn
) (car tn
) tn
))
722 (sc (tn-sc first-tn
))
724 #!-
(or x86 x86-64
) (temp-tn (make-representation-tn
725 (tn-primitive-type first-tn
) scn
))
726 (move-arg-vops (svref (sc-move-arg-vops sc
) scn
)))
728 (unless (= (length move-arg-vops
) 1)
729 (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc
)))
730 #!+(or x86 x86-64
) (emit-move-arg-template call
732 (first move-arg-vops
)
733 (lvar-tn call block arg
)
736 #!-
(or x86 x86-64
) (progn
739 (lvar-tn call block arg
)
741 (emit-move-arg-template call
743 (first move-arg-vops
)
749 ;; This means that we have a float arg that we need to
750 ;; also copy to some int regs. The list contains the TN
751 ;; for the float as well as the TNs to use for the int
753 (destructuring-bind (float-tn i1-tn
&optional i2-tn
)
756 (vop sb
!vm
::move-double-to-int-arg call block
757 float-tn i1-tn i2-tn
)
758 (vop sb
!vm
::move-single-to-int-arg call block
761 (unless (listp result-tns
)
762 (setf result-tns
(list result-tns
)))
763 (let ((arg-tns (flatten-list arg-tns
)))
764 (vop* call-out call block
765 ((lvar-tn call block function
)
766 (reference-tn-list arg-tns nil
))
767 ((reference-tn-list result-tns t
))))
769 (vop dealloc-number-stack-space call block stack-frame-size
)
772 (vop reset-stack-pointer call block stack-pointer
)
773 (vop set-fpu-word-for-lisp call block
))
774 (move-lvar-result call block result-tns lvar
))))