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 `(%primitive alloc-alien-stack-space
354 ,(ceiling (alien-type-bits alien-type
)
357 `(%primitive alloc-number-stack-space
358 ,(ceiling (alien-type-bits alien-type
)
360 (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type
))
361 (alien-rep-type (specifier-type alien-rep-type-spec
)))
362 (cond ((csubtypep (specifier-type 'system-area-pointer
)
365 ((ctypep 0 alien-rep-type
) 0)
366 ((ctypep 0.0f0 alien-rep-type
) 0.0f0
)
367 ((ctypep 0.0d0 alien-rep-type
) 0.0d0
)
370 "Aliens of type ~S cannot be represented immediately."
371 (unparse-alien-type alien-type
))))))))
373 (deftransform note-local-alien-type
((info var
) * * :important t
)
374 ;; FIXME: This test and error occur about a zillion times. They
375 ;; could be factored into a function.
376 (unless (constant-lvar-p info
)
377 (abort-ir1-transform "Local alien info isn't constant?"))
378 (let ((info (lvar-value info
)))
379 (/noshow
"in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info
)
380 (/noshow
(local-alien-info-force-to-memory-p info
))
381 (unless (local-alien-info-force-to-memory-p info
)
382 (let ((var-node (lvar-uses var
)))
383 (/noshow var-node
(ref-p var-node
))
384 (when (ref-p var-node
)
385 (propagate-to-refs (ref-leaf var-node
)
387 (compute-alien-rep-type
388 (local-alien-info-type info
))))))))
391 (deftransform local-alien
((info var
) * * :important t
)
392 (unless (constant-lvar-p info
)
393 (abort-ir1-transform "Local alien info isn't constant?"))
394 (let* ((info (lvar-value info
))
395 (alien-type (local-alien-info-type info
)))
396 (/noshow
"in DEFTRANSFORM LOCAL-ALIEN" info alien-type
)
397 (/noshow
(local-alien-info-force-to-memory-p info
))
398 (if (local-alien-info-force-to-memory-p info
)
399 `(extract-alien-value var
0 ',alien-type
)
400 `(naturalize var
',alien-type
))))
402 (deftransform %local-alien-forced-to-memory-p
((info) * * :important t
)
403 (unless (constant-lvar-p info
)
404 (abort-ir1-transform "Local alien info isn't constant?"))
405 (let ((info (lvar-value info
)))
406 (local-alien-info-force-to-memory-p info
)))
408 (deftransform %set-local-alien
((info var value
) * * :important t
)
409 (unless (constant-lvar-p info
)
410 (abort-ir1-transform "Local alien info isn't constant?"))
411 (let* ((info (lvar-value info
))
412 (alien-type (local-alien-info-type info
)))
413 (if (local-alien-info-force-to-memory-p info
)
414 `(deposit-alien-value var
0 ',alien-type value
)
415 '(error "This should be eliminated as dead code."))))
417 (defoptimizer (%local-alien-addr derive-type
) ((info var
))
418 (if (constant-lvar-p info
)
419 (let* ((info (lvar-value info
))
420 (alien-type (local-alien-info-type info
)))
421 (make-alien-type-type (make-alien-pointer-type :to alien-type
)))
424 (deftransform %local-alien-addr
((info var
) * * :important t
)
425 (unless (constant-lvar-p info
)
426 (abort-ir1-transform "Local alien info isn't constant?"))
427 (let* ((info (lvar-value info
))
428 (alien-type (local-alien-info-type info
)))
429 (/noshow
"in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
430 (if (local-alien-info-force-to-memory-p info
)
431 `(%sap-alien var
',(make-alien-pointer-type :to alien-type
))
432 (error "This shouldn't happen."))))
434 (deftransform dispose-local-alien
((info var
) * * :important t
)
435 (unless (constant-lvar-p info
)
436 (abort-ir1-transform "Local alien info isn't constant?"))
437 (let* ((info (lvar-value info
))
438 (alien-type (local-alien-info-type info
)))
439 (if (local-alien-info-force-to-memory-p info
)
440 #!+(or x86 x86-64
) `(%primitive dealloc-alien-stack-space
441 ,(ceiling (alien-type-bits alien-type
)
443 #!-
(or x86 x86-64
) `(%primitive dealloc-number-stack-space
444 ,(ceiling (alien-type-bits alien-type
)
450 (defoptimizer (%cast derive-type
) ((alien type
))
451 (or (when (constant-lvar-p type
)
452 (let ((alien-type (lvar-value type
)))
453 (when (alien-type-p alien-type
)
454 (make-alien-type-type alien-type
))))
457 (deftransform %cast
((alien target-type
) * * :important t
)
458 (unless (constant-lvar-p target-type
)
459 (give-up-ir1-transform
460 "The alien type is not constant, so access cannot be open coded."))
461 (let ((target-type (lvar-value target-type
)))
462 (cond ((or (alien-pointer-type-p target-type
)
463 (alien-array-type-p target-type
)
464 (alien-fun-type-p target-type
))
465 `(naturalize (alien-sap alien
) ',target-type
))
467 (abort-ir1-transform "cannot cast to alien type ~S" target-type
)))))
469 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
471 (deftransform alien-sap
((alien) * * :important t
)
472 (let ((alien-node (lvar-uses alien
)))
475 (splice-fun-args alien
'%sap-alien
2)
477 (declare (ignore type
))
480 (give-up-ir1-transform)))))
482 (defoptimizer (%sap-alien derive-type
) ((sap type
))
483 (declare (ignore sap
))
484 (if (constant-lvar-p type
)
485 (make-alien-type-type (lvar-value type
))
488 (deftransform %sap-alien
((sap type
) * * :important t
)
489 (give-up-ir1-transform
490 ;; FIXME: The hardcoded newline here causes more-than-usually
491 ;; screwed-up formatting of the optimization note output.
492 "could not optimize away %SAP-ALIEN: forced to do runtime ~@
493 allocation of alien-value structure"))
495 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
497 (flet ((%computed-lambda
(compute-lambda type
)
498 (declare (type function compute-lambda
))
499 (unless (constant-lvar-p type
)
500 (give-up-ir1-transform
501 "The type is not constant at compile time; can't open code."))
503 (let ((result (funcall compute-lambda
(lvar-value type
))))
504 (/noshow
"in %COMPUTED-LAMBDA" (lvar-value type
) result
)
507 (compiler-error "~A" condition
)))))
508 (deftransform naturalize
((object type
) * * :important t
)
509 (%computed-lambda
#'compute-naturalize-lambda type
))
510 (deftransform deport
((alien type
) * * :important t
)
511 (%computed-lambda
#'compute-deport-lambda type
))
512 (deftransform deport-alloc
((alien type
) * * :important t
)
513 (%computed-lambda
#'compute-deport-alloc-lambda type
))
514 (deftransform extract-alien-value
((sap offset type
) * * :important t
)
515 (%computed-lambda
#'compute-extract-lambda type
))
516 (deftransform deposit-alien-value
((sap offset type value
) * * :important t
)
517 (%computed-lambda
#'compute-deposit-lambda type
)))
519 ;;;; a hack to clean up divisions
521 (defun count-low-order-zeros (thing)
524 (if (constant-lvar-p thing
)
525 (count-low-order-zeros (lvar-value thing
))
526 (count-low-order-zeros (lvar-uses thing
))))
528 (case (let ((name (lvar-fun-name (combination-fun thing
))))
529 (or (modular-version-info name
:untagged nil
) name
))
531 (let ((min most-positive-fixnum
)
532 (itype (specifier-type 'integer
)))
533 (dolist (arg (combination-args thing
) min
)
534 (if (csubtypep (lvar-type arg
) itype
)
535 (setf min
(min min
(count-low-order-zeros arg
)))
539 (itype (specifier-type 'integer
)))
540 (dolist (arg (combination-args thing
) result
)
541 (if (csubtypep (lvar-type arg
) itype
)
542 (setf result
(+ result
(count-low-order-zeros arg
)))
545 (let ((args (combination-args thing
)))
546 (if (= (length args
) 2)
547 (let ((amount (second args
)))
548 (if (constant-lvar-p amount
)
549 (max (+ (count-low-order-zeros (first args
))
559 (do ((result 0 (1+ result
))
560 (num thing
(ash num -
1)))
561 ((logbitp 0 num
) result
))))
563 (count-low-order-zeros (cast-value thing
)))
567 (deftransform / ((numerator denominator
) (integer integer
))
568 "convert x/2^k to shift"
569 (unless (constant-lvar-p denominator
)
570 (give-up-ir1-transform))
571 (let* ((denominator (lvar-value denominator
))
572 (bits (1- (integer-length denominator
))))
573 (unless (and (> denominator
0) (= (ash 1 bits
) denominator
))
574 (give-up-ir1-transform))
575 (let ((alignment (count-low-order-zeros numerator
)))
576 (unless (>= alignment bits
)
577 (give-up-ir1-transform))
578 `(ash numerator
,(- bits
)))))
580 (deftransform ash
((value amount
))
581 (let ((value-node (lvar-uses value
)))
582 (unless (combination-p value-node
)
583 (give-up-ir1-transform))
584 (let ((inside-fun-name (lvar-fun-name (combination-fun value-node
))))
585 (multiple-value-bind (prototype width
)
586 (modular-version-info inside-fun-name
:untagged nil
)
587 (unless (eq (or prototype inside-fun-name
) 'ash
)
588 (give-up-ir1-transform))
589 (when (and width
(not (constant-lvar-p amount
)))
590 (give-up-ir1-transform))
591 (let ((inside-args (combination-args value-node
)))
592 (unless (= (length inside-args
) 2)
593 (give-up-ir1-transform))
594 (let ((inside-amount (second inside-args
)))
595 (unless (and (constant-lvar-p inside-amount
)
596 (not (minusp (lvar-value inside-amount
))))
597 (give-up-ir1-transform)))
598 (splice-fun-args value inside-fun-name
2)
600 `(lambda (value amount1 amount2
)
601 (logand (ash value
(+ amount1 amount2
))
602 ,(1- (ash 1 (+ width
(lvar-value amount
))))))
603 `(lambda (value amount1 amount2
)
604 (ash value
(+ amount1 amount2
)))))))))
606 ;;;; ALIEN-FUNCALL support
608 (deftransform alien-funcall
((function &rest args
)
609 ((alien (* t
)) &rest
*) *
611 (let ((names (make-gensym-list (length args
))))
612 (/noshow
"entering first DEFTRANSFORM ALIEN-FUNCALL" function args
)
613 `(lambda (function ,@names
)
614 (alien-funcall (deref function
) ,@names
))))
616 (deftransform alien-funcall
((function &rest args
) * * :important t
)
617 (let ((type (lvar-type function
)))
618 (unless (alien-type-type-p type
)
619 (give-up-ir1-transform "can't tell function type at compile time"))
620 (/noshow
"entering second DEFTRANSFORM ALIEN-FUNCALL" function
)
621 (let ((alien-type (alien-type-type-alien-type type
)))
622 (unless (alien-fun-type-p alien-type
)
623 (give-up-ir1-transform))
624 (let ((arg-types (alien-fun-type-arg-types alien-type
)))
625 (unless (= (length args
) (length arg-types
))
627 "wrong number of arguments; expected ~W, got ~W"
630 (collect ((params) (deports))
631 (dolist (arg-type arg-types
)
632 (let ((param (gensym)))
634 (deports `(deport ,param
',arg-type
))))
635 ;; Build BODY from the inside out.
636 (let ((return-type (alien-fun-type-result-type alien-type
))
637 ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
638 ;; to them) and do the call.
639 (body `(%alien-funcall
(deport function
',alien-type
)
642 ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
643 ;; the SAPs are taken for won't be moved by the GC. (If
644 ;; needed: some alien types won't need it).
645 (setf body
`(maybe-with-pinned-objects ,(params) ,arg-types
647 ;; Around that handle any memory allocation that's needed.
648 ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
649 ;; identity operation, but for example for deporting a
650 ;; Unicode string we need to convert the string into an
651 ;; octet array. This step needs to be done before the pinning
652 ;; to ensure we pin the right objects, so it can't be combined
653 ;; with the deporting.
655 (loop for param in
(params)
656 for arg-type in arg-types
658 `(let ((,param
(deport-alloc ,param
',arg-type
)))
660 (if (alien-values-type-p return-type
)
661 (collect ((temps) (results))
662 (dolist (type (alien-values-type-values return-type
))
663 (let ((temp (gensym)))
665 (results `(naturalize ,temp
',type
))))
667 `(multiple-value-bind ,(temps) ,body
668 (values ,@(results)))))
669 (setf body
`(naturalize ,body
',return-type
)))
670 (/noshow
"returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body
)
671 `(lambda (function ,@(params))
674 (defoptimizer (%alien-funcall derive-type
) ((function type
&rest args
))
675 (declare (ignore function args
))
676 (unless (constant-lvar-p type
)
677 (error "Something is broken."))
678 (let ((type (lvar-value type
)))
679 (unless (alien-fun-type-p type
)
680 (error "Something is broken."))
681 (values-specifier-type
682 (compute-alien-rep-type
683 (alien-fun-type-result-type type
)))))
685 (defoptimizer (%alien-funcall ltn-annotate
)
686 ((function type
&rest args
) node ltn-policy
)
687 (setf (basic-combination-info node
) :funny
)
688 (setf (node-tail-p node
) nil
)
689 (annotate-ordinary-lvar function
)
691 (annotate-ordinary-lvar arg
)))
693 ;;; We support both the stdcall and cdecl calling conventions on win32 by
694 ;;; resetting ESP after the foreign function returns. This way it works
695 ;;; correctly whether the party that is supposed to pop arguments from
696 ;;; the stack is the caller (cdecl) or the callee (stdcall).
697 (defoptimizer (%alien-funcall ir2-convert
)
698 ((function type
&rest args
) call block
)
699 (let ((type (if (constant-lvar-p type
)
701 (error "Something is broken.")))
702 (lvar (node-lvar call
))
705 (stack-pointer (make-stack-pointer-tn)))
706 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns
)
707 (make-call-out-tns type
)
710 (vop set-fpu-word-for-c call block
)
711 (vop current-stack-pointer call block stack-pointer
))
712 (vop alloc-number-stack-space call block stack-frame-size nsp
)
714 ;; On PPC, TN might be a list. This is used to indicate
715 ;; something special needs to happen. See below.
717 ;; FIXME: We should implement something better than this.
718 (let* ((first-tn (if (listp tn
) (car tn
) tn
))
720 (sc (tn-sc first-tn
))
722 #!-
(or x86 x86-64
) (temp-tn (make-representation-tn
723 (tn-primitive-type first-tn
) scn
))
724 (move-arg-vops (svref (sc-move-arg-vops sc
) scn
)))
726 (unless (= (length move-arg-vops
) 1)
727 (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc
)))
728 #!+(or x86 x86-64
) (emit-move-arg-template call
730 (first move-arg-vops
)
731 (lvar-tn call block arg
)
734 #!-
(or x86 x86-64
) (progn
737 (lvar-tn call block arg
)
739 (emit-move-arg-template call
741 (first move-arg-vops
)
747 ;; This means that we have a float arg that we need to
748 ;; also copy to some int regs. The list contains the TN
749 ;; for the float as well as the TNs to use for the int
751 (destructuring-bind (float-tn i1-tn
&optional i2-tn
)
754 (vop sb
!vm
::move-double-to-int-arg call block
755 float-tn i1-tn i2-tn
)
756 (vop sb
!vm
::move-single-to-int-arg call block
759 (unless (listp result-tns
)
760 (setf result-tns
(list result-tns
)))
761 (let ((arg-tns (flatten-list arg-tns
)))
762 (vop* call-out call block
763 ((lvar-tn call block function
)
764 (reference-tn-list arg-tns nil
))
765 ((reference-tn-list result-tns t
))))
767 (vop dealloc-number-stack-space call block stack-frame-size
)
770 (vop reset-stack-pointer call block stack-pointer
)
771 (vop set-fpu-word-for-lisp call block
))
772 (move-lvar-result call block result-tns lvar
))))