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 %alien-value
(system-area-pointer unsigned-byte alien-type
) t
68 (defknown (setf %alien-value
) (t system-area-pointer unsigned-byte alien-type
) 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"
106 (values (alien-record-field-offset field
)
107 (alien-record-field-type field
))))))
109 #+nil
;; Shouldn't be necessary.
110 (defoptimizer (slot derive-type
) ((alien slot
))
112 (catch 'give-up-ir1-transform
113 (multiple-value-bind (slot-offset slot-type
)
114 (find-slot-offset-and-type alien slot
)
115 (declare (ignore slot-offset
))
116 (return (make-alien-type-type slot-type
))))
119 (deftransform slot
((alien slot
) * * :important t
)
120 (multiple-value-bind (slot-offset slot-type
)
121 (find-slot-offset-and-type alien slot
)
122 `(%alien-value
(alien-sap alien
)
126 #+nil
;; ### But what about coercions?
127 (defoptimizer (%set-slot derive-type
) ((alien slot value
))
129 (catch 'give-up-ir1-transform
130 (multiple-value-bind (slot-offset slot-type
)
131 (find-slot-offset-and-type alien slot
)
132 (declare (ignore slot-offset
))
133 (let ((type (make-alien-type-type slot-type
)))
134 (assert-lvar-type value type
)
138 (deftransform %set-slot
((alien slot value
) * * :important t
)
139 (multiple-value-bind (slot-offset slot-type
)
140 (find-slot-offset-and-type alien slot
)
141 `(setf (%alien-value
(alien-sap alien
)
146 (defoptimizer (%slot-addr derive-type
) ((alien slot
))
148 (catch 'give-up-ir1-transform
149 (multiple-value-bind (slot-offset slot-type
)
150 (find-slot-offset-and-type alien slot
)
151 (declare (ignore slot-offset
))
152 (return (make-alien-type-type
153 (make-alien-pointer-type :to slot-type
)))))
156 (deftransform %slot-addr
((alien slot
) * * :important t
)
157 (multiple-value-bind (slot-offset slot-type
)
158 (find-slot-offset-and-type alien slot
)
159 (/noshow
"in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
160 `(%sap-alien
(sap+ (alien-sap alien
) (/ ,slot-offset sb
!vm
:n-byte-bits
))
161 ',(make-alien-pointer-type :to slot-type
))))
165 (defun find-deref-alien-type (alien)
166 (let ((alien-type (lvar-type alien
)))
167 (unless (alien-type-type-p alien-type
)
168 (give-up-ir1-transform))
169 (let ((alien-type (alien-type-type-alien-type alien-type
)))
170 (if (alien-type-p alien-type
)
172 (give-up-ir1-transform)))))
174 (defun find-deref-element-type (alien)
175 (let ((alien-type (find-deref-alien-type alien
)))
178 (alien-pointer-type-to alien-type
))
180 (alien-array-type-element-type alien-type
))
182 (give-up-ir1-transform)))))
184 (defun compute-deref-guts (alien indices
)
185 (let ((alien-type (find-deref-alien-type alien
)))
189 (abort-ir1-transform "too many indices for pointer deref: ~W"
191 (let ((element-type (alien-pointer-type-to alien-type
)))
193 (give-up-ir1-transform "unable to open code deref of wild pointer type"))
195 (let ((bits (alien-type-bits element-type
))
196 (alignment (alien-type-alignment element-type
)))
198 (abort-ir1-transform "unknown element size"))
200 (abort-ir1-transform "unknown element alignment"))
203 ,(align-offset bits alignment
))
205 (values nil
0 element-type
))))
207 (let* ((element-type (alien-array-type-element-type alien-type
))
208 (bits (alien-type-bits element-type
))
209 (alignment (alien-type-alignment element-type
))
210 (dims (alien-array-type-dimensions alien-type
)))
211 (unless (= (length indices
) (length dims
))
212 (give-up-ir1-transform "incorrect number of indices"))
214 (give-up-ir1-transform "Element size is unknown."))
216 (give-up-ir1-transform "Element alignment is unknown."))
218 (values nil
0 element-type
)
219 (let* ((arg (gensym))
222 (dolist (dim (cdr dims
))
223 (let ((arg (gensym)))
225 (setf offsetexpr
`(+ (* ,offsetexpr
,dim
) ,arg
))))
226 (values (reverse args
)
228 ,(align-offset bits alignment
))
231 (abort-ir1-transform "~S not either a pointer or array type."
234 #+nil
;; Shouldn't be necessary.
235 (defoptimizer (deref derive-type
) ((alien &rest noise
))
236 (declare (ignore noise
))
238 (catch 'give-up-ir1-transform
239 (return (make-alien-type-type (find-deref-element-type alien
))))
242 (deftransform deref
((alien &rest indices
) * * :important t
)
243 (multiple-value-bind (indices-args offset-expr element-type
)
244 (compute-deref-guts alien indices
)
245 `(lambda (alien ,@indices-args
)
246 (%alien-value
(alien-sap alien
)
250 #+nil
;; ### Again, the value might be coerced.
251 (defoptimizer (%set-deref derive-type
) ((alien value
&rest noise
))
252 (declare (ignore noise
))
254 (catch 'give-up-ir1-transform
255 (let ((type (make-alien-type-type
256 (make-alien-pointer-type
257 :to
(find-deref-element-type alien
)))))
258 (assert-lvar-type value type
)
262 (deftransform %set-deref
((alien value
&rest indices
) * * :important t
)
263 (multiple-value-bind (indices-args offset-expr element-type
)
264 (compute-deref-guts alien indices
)
265 `(lambda (alien value
,@indices-args
)
266 (setf (%alien-value
(alien-sap alien
)
271 (defoptimizer (%deref-addr derive-type
) ((alien &rest noise
))
272 (declare (ignore noise
))
274 (catch 'give-up-ir1-transform
275 (return (make-alien-type-type
276 (make-alien-pointer-type
277 :to
(find-deref-element-type alien
)))))
280 (deftransform %deref-addr
((alien &rest indices
) * * :important t
)
281 (multiple-value-bind (indices-args offset-expr element-type
)
282 (compute-deref-guts alien indices
)
283 (/noshow
"in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
284 `(lambda (alien ,@indices-args
)
285 (%sap-alien
(sap+ (alien-sap alien
) (/ ,offset-expr sb
!vm
:n-byte-bits
))
286 ',(make-alien-pointer-type :to element-type
)))))
288 ;;;; support for aliens on the heap
290 (defun heap-alien-sap-and-type (info)
291 (unless (constant-lvar-p info
)
292 (give-up-ir1-transform "info not constant; can't open code"))
293 (let ((info (lvar-value info
)))
294 (values (heap-alien-info-sap-form info
)
295 (heap-alien-info-type info
))))
297 #+nil
; shouldn't be necessary
298 (defoptimizer (%heap-alien derive-type
) ((info))
301 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
302 (declare (ignore sap
))
303 (return (make-alien-type-type type
))))
306 (deftransform %heap-alien
((info) ((constant-arg heap-alien-info
)) * :important t
)
307 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
308 `(%alien-value
,sap
0 ',type
)))
310 #+nil
;; ### Again, deposit value might change the type.
311 (defoptimizer (%set-heap-alien derive-type
) ((info value
))
313 (catch 'give-up-ir1-transform
314 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
315 (declare (ignore sap
))
316 (let ((type (make-alien-type-type type
)))
317 (assert-lvar-type value type
)
321 (deftransform %set-heap-alien
((info value
) (heap-alien-info *) * :important t
)
322 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
323 `(setf (%alien-value
,sap
0 ',type
) value
)))
325 (defoptimizer (%heap-alien-addr derive-type
) ((info))
327 (catch 'give-up-ir1-transform
328 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
329 (declare (ignore sap
))
330 (return (make-alien-type-type (make-alien-pointer-type :to type
)))))
333 (deftransform %heap-alien-addr
((info) * * :important t
)
334 (multiple-value-bind (sap type
) (heap-alien-sap-and-type info
)
335 (/noshow
"in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
336 `(%sap-alien
,sap
',(make-alien-pointer-type :to type
))))
339 ;;;; support for local (stack or register) aliens
341 (defun alien-info-constant-or-abort (info)
342 (unless (constant-lvar-p info
)
343 (abort-ir1-transform "Local alien info isn't constant?")))
345 (deftransform make-local-alien
((info) * * :important t
)
346 (alien-info-constant-or-abort info
)
347 (let* ((info (lvar-value info
))
348 (alien-type (local-alien-info-type info
))
349 (bits (alien-type-bits alien-type
)))
351 (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type
)))
352 (/noshow
"in DEFTRANSFORM MAKE-LOCAL-ALIEN" info
)
353 (/noshow
(local-alien-info-force-to-memory-p info
))
354 (/noshow alien-type
(unparse-alien-type alien-type
) (alien-type-bits alien-type
))
355 (if (local-alien-info-force-to-memory-p info
)
357 `(%primitive alloc-alien-stack-space
358 ,(ceiling (alien-type-bits alien-type
)
361 `(%primitive alloc-number-stack-space
362 ,(ceiling (alien-type-bits alien-type
)
364 (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type
))
365 (alien-rep-type (specifier-type alien-rep-type-spec
)))
366 (cond ((csubtypep (specifier-type 'system-area-pointer
)
369 ((ctypep 0 alien-rep-type
) 0)
370 ((ctypep 0.0f0 alien-rep-type
) 0.0f0
)
371 ((ctypep 0.0d0 alien-rep-type
) 0.0d0
)
374 "Aliens of type ~S cannot be represented immediately."
375 (unparse-alien-type alien-type
))))))))
377 (deftransform note-local-alien-type
((info var
) * * :important t
)
378 (alien-info-constant-or-abort info
)
379 (let ((info (lvar-value info
)))
380 (unless (local-alien-info-force-to-memory-p info
)
381 (let ((var-node (lvar-uses var
)))
382 (when (and (ref-p var-node
)
383 (constant-reference-p var-node
))
384 (propagate-to-refs (ref-leaf var-node
)
386 (compute-alien-rep-type
387 (local-alien-info-type info
))))))))
390 (deftransform local-alien
((info var
) * * :important t
)
391 (alien-info-constant-or-abort info
)
392 (let* ((info (lvar-value info
))
393 (alien-type (local-alien-info-type info
)))
394 (/noshow
"in DEFTRANSFORM LOCAL-ALIEN" info alien-type
)
395 (/noshow
(local-alien-info-force-to-memory-p info
))
396 (if (local-alien-info-force-to-memory-p info
)
397 `(%alien-value var
0 ',alien-type
)
398 `(naturalize var
',alien-type
))))
400 (deftransform %local-alien-forced-to-memory-p
((info) * * :important t
)
401 (alien-info-constant-or-abort info
)
402 (let ((info (lvar-value info
)))
403 (local-alien-info-force-to-memory-p info
)))
405 (deftransform %set-local-alien
((info var value
) * * :important t
)
406 (alien-info-constant-or-abort info
)
407 (let* ((info (lvar-value info
))
408 (alien-type (local-alien-info-type info
)))
409 (if (local-alien-info-force-to-memory-p info
)
410 `(setf (%alien-value var
0 ',alien-type
) value
)
411 '(error "This should be eliminated as dead code."))))
413 (defoptimizer (%local-alien-addr derive-type
) ((info var
))
414 (declare (ignore var
))
415 (if (constant-lvar-p info
)
416 (let* ((info (lvar-value info
))
417 (alien-type (local-alien-info-type info
)))
418 (make-alien-type-type (make-alien-pointer-type :to alien-type
)))
421 (deftransform %local-alien-addr
((info var
) * * :important t
)
422 (alien-info-constant-or-abort info
)
423 (let* ((info (lvar-value info
))
424 (alien-type (local-alien-info-type info
)))
425 (/noshow
"in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
426 (if (local-alien-info-force-to-memory-p info
)
427 `(%sap-alien var
',(make-alien-pointer-type :to alien-type
))
428 (error "This shouldn't happen."))))
430 ;; DISPOSE-LOCAL-ALIEN can't happens on x86[-64].
431 ;; A transform of it is just misdirection.
433 (deftransform dispose-local-alien
((info var
) * * :important t
)
434 (alien-info-constant-or-abort info
)
435 (let* ((info (lvar-value info
))
436 (alien-type (local-alien-info-type info
)))
437 (if (local-alien-info-force-to-memory-p info
)
438 `(%primitive dealloc-number-stack-space
439 ,(ceiling (alien-type-bits alien-type
)
445 (defoptimizer (%cast derive-type
) ((alien type
))
446 (declare (ignore alien
))
447 (or (when (constant-lvar-p type
)
448 (let ((alien-type (lvar-value type
)))
449 (when (alien-type-p alien-type
)
450 (make-alien-type-type alien-type
))))
453 (deftransform %cast
((alien target-type
) * * :important t
)
454 (unless (constant-lvar-p target-type
)
455 (give-up-ir1-transform
456 "The alien type is not constant, so access cannot be open coded."))
457 (let ((target-type (lvar-value target-type
)))
458 (cond ((or (alien-pointer-type-p target-type
)
459 (alien-array-type-p target-type
)
460 (alien-fun-type-p target-type
))
461 `(naturalize (alien-sap alien
) ',target-type
))
463 (abort-ir1-transform "cannot cast to alien type ~S" target-type
)))))
465 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
467 (deftransform alien-sap
((alien) * * :important t
)
468 (let ((alien-node (lvar-uses alien
)))
471 (splice-fun-args alien
'%sap-alien
2)
473 (declare (ignore type
))
476 (give-up-ir1-transform)))))
478 (defoptimizer (%sap-alien derive-type
) ((sap type
))
479 (declare (ignore sap
))
480 (if (constant-lvar-p type
)
481 (make-alien-type-type (lvar-value type
))
484 (deftransform %sap-alien
((sap type
) * * :important t
)
485 (give-up-ir1-transform
486 ;; FIXME: The hardcoded newline here causes more-than-usually
487 ;; screwed-up formatting of the optimization note output.
488 "could not optimize away %SAP-ALIEN: forced to do runtime ~@
489 allocation of alien-value structure"))
491 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
493 (flet ((%computed-lambda
(compute-lambda type
)
494 (declare (type function compute-lambda
))
495 (unless (constant-lvar-p type
)
496 (give-up-ir1-transform
497 "The type is not constant at compile time; can't open code."))
499 (let ((result (funcall compute-lambda
(lvar-value type
))))
500 (/noshow
"in %COMPUTED-LAMBDA" (lvar-value type
) result
)
503 (compiler-error "~A" condition
)))))
504 (deftransform naturalize
((object type
) * * :important t
)
505 (%computed-lambda
#'compute-naturalize-lambda type
))
506 (deftransform deport
((alien type
) * * :important t
)
507 (%computed-lambda
#'compute-deport-lambda type
))
508 (deftransform deport-alloc
((alien type
) * * :important t
)
509 (%computed-lambda
#'compute-deport-alloc-lambda type
))
510 (deftransform %alien-value
((sap offset type
) * * :important t
)
511 (%computed-lambda
#'compute-extract-lambda type
))
512 (deftransform (setf %alien-value
) ((value sap offset type
) * * :important t
)
513 (%computed-lambda
#'compute-deposit-lambda type
)))
515 ;;;; a hack to clean up divisions
517 (defun count-low-order-zeros (thing)
520 (if (constant-lvar-p thing
)
521 (count-low-order-zeros (lvar-value thing
))
522 (count-low-order-zeros (lvar-uses thing
))))
524 (case (let ((name (lvar-fun-name (combination-fun thing
))))
525 (or (modular-version-info name
:untagged nil
) name
))
527 (let ((min most-positive-fixnum
)
528 (itype (specifier-type 'integer
)))
529 (dolist (arg (combination-args thing
) min
)
530 (if (csubtypep (lvar-type arg
) itype
)
531 (setf min
(min min
(count-low-order-zeros arg
)))
535 (itype (specifier-type 'integer
)))
536 (dolist (arg (combination-args thing
) result
)
537 (if (csubtypep (lvar-type arg
) itype
)
538 (setf result
(+ result
(count-low-order-zeros arg
)))
541 (let ((args (combination-args thing
)))
542 (if (= (length args
) 2)
543 (let ((amount (second args
)))
544 (if (constant-lvar-p amount
)
545 (max (+ (count-low-order-zeros (first args
))
555 (do ((result 0 (1+ result
))
556 (num thing
(ash num -
1)))
557 ((logbitp 0 num
) result
))))
559 (count-low-order-zeros (cast-value thing
)))
563 (deftransform / ((numerator denominator
) (integer integer
))
564 "convert x/2^k to shift"
565 (unless (constant-lvar-p denominator
)
566 (give-up-ir1-transform))
567 (let* ((denominator (lvar-value denominator
))
568 (bits (1- (integer-length denominator
))))
569 (unless (and (> denominator
0) (= (ash 1 bits
) denominator
))
570 (give-up-ir1-transform))
571 (let ((alignment (count-low-order-zeros numerator
)))
572 (unless (>= alignment bits
)
573 (give-up-ir1-transform))
574 `(ash numerator
,(- bits
)))))
576 (deftransform ash
((value amount
))
577 (let ((value-node (lvar-uses value
)))
578 (unless (combination-p value-node
)
579 (give-up-ir1-transform))
580 (let ((inside-fun-name (lvar-fun-name (combination-fun value-node
))))
581 (multiple-value-bind (prototype width
)
582 (modular-version-info inside-fun-name
:untagged nil
)
583 (unless (eq (or prototype inside-fun-name
) 'ash
)
584 (give-up-ir1-transform))
585 (when (and width
(not (constant-lvar-p amount
)))
586 (give-up-ir1-transform))
587 (let ((inside-args (combination-args value-node
)))
588 (unless (= (length inside-args
) 2)
589 (give-up-ir1-transform))
590 (let ((inside-amount (second inside-args
)))
591 (unless (and (constant-lvar-p inside-amount
)
592 (not (minusp (lvar-value inside-amount
))))
593 (give-up-ir1-transform)))
594 (splice-fun-args value inside-fun-name
2)
596 `(lambda (value amount1 amount2
)
597 (logand (ash value
(+ amount1 amount2
))
598 ,(1- (ash 1 (+ width
(lvar-value amount
))))))
599 `(lambda (value amount1 amount2
)
600 (ash value
(+ amount1 amount2
)))))))))
602 ;;;; ALIEN-FUNCALL support
604 (deftransform alien-funcall
((function &rest args
)
605 ((alien (* t
)) &rest
*) *
607 (let ((names (make-gensym-list (length args
))))
608 (/noshow
"entering first DEFTRANSFORM ALIEN-FUNCALL" function args
)
609 `(lambda (function ,@names
)
610 (alien-funcall (deref function
) ,@names
))))
613 (defun find-saved-fp-and-pc (fp)
614 (dolist (x *saved-fp-and-pcs
*)
615 (declare (type (simple-array word
(2)) x
))
616 (when (#!+stack-grows-downward-not-upward
618 #!-stack-grows-downward-not-upward
620 (int-sap (aref x
0)) fp
)
621 (return (values (int-sap (aref x
0)) (int-sap (aref x
1)))))))
623 (deftransform alien-funcall
((function &rest args
) * * :node node
:important t
)
624 (let ((type (lvar-type function
)))
625 (unless (alien-type-type-p type
)
626 (give-up-ir1-transform "can't tell function type at compile time"))
627 (/noshow
"entering second DEFTRANSFORM ALIEN-FUNCALL" function
)
628 (let ((alien-type (alien-type-type-alien-type type
)))
629 (unless (alien-fun-type-p alien-type
)
630 (give-up-ir1-transform))
631 (let ((arg-types (alien-fun-type-arg-types alien-type
)))
632 (unless (= (length args
) (length arg-types
))
634 "wrong number of arguments; expected ~W, got ~W"
637 (collect ((params) (deports))
638 (dolist (arg-type arg-types
)
639 (let ((param (gensym)))
641 (deports `(deport ,param
',arg-type
))))
642 ;; Build BODY from the inside out.
643 (let ((return-type (alien-fun-type-result-type alien-type
))
644 ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
645 ;; to them) and do the call.
646 (body `(%alien-funcall
(deport function
',alien-type
)
649 ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
650 ;; the SAPs are taken for won't be moved by the GC. (If
651 ;; needed: some alien types won't need it).
652 (setf body
`(maybe-with-pinned-objects ,(params) ,arg-types
654 ;; Around that handle any memory allocation that's needed.
655 ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
656 ;; identity operation, but for example for deporting a
657 ;; Unicode string we need to convert the string into an
658 ;; octet array. This step needs to be done before the pinning
659 ;; to ensure we pin the right objects, so it can't be combined
660 ;; with the deporting.
662 (loop for param in
(params)
663 for arg-type in arg-types
665 `(let ((,param
(deport-alloc ,param
',arg-type
)))
667 (if (alien-values-type-p return-type
)
668 (collect ((temps) (results))
669 (dolist (type (alien-values-type-values return-type
))
670 (let ((temp (gensym)))
672 (results `(naturalize ,temp
',type
))))
674 `(multiple-value-bind ,(temps) ,body
675 (values ,@(results)))))
676 (setf body
`(naturalize ,body
',return-type
)))
677 ;; Remember this frame to make sure that we can get back
678 ;; to it later regardless of how the foreign stack looks
680 #!+c-stack-is-control-stack
681 (when (policy node
(= 3 alien-funcall-saves-fp-and-pc
))
682 (setf body
`(invoke-with-saved-fp-and-pc (lambda () ,body
))))
683 (/noshow
"returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body
)
684 `(lambda (function ,@(params))
685 (declare (optimize (let-conversion 3)))
688 (defoptimizer (%alien-funcall derive-type
) ((function type
&rest args
))
689 (declare (ignore function args
))
690 (unless (constant-lvar-p type
)
691 (error "Something is broken."))
692 (let ((type (lvar-value type
)))
693 (unless (alien-fun-type-p type
)
694 (error "Something is broken."))
695 (values-specifier-type
696 (compute-alien-rep-type
697 (alien-fun-type-result-type type
)
700 (defoptimizer (%alien-funcall ltn-annotate
)
701 ((function type
&rest args
) node ltn-policy
)
702 (declare (ignore type ltn-policy
))
703 (setf (basic-combination-info node
) :funny
)
704 (setf (node-tail-p node
) nil
)
705 (annotate-ordinary-lvar function
)
707 (annotate-ordinary-lvar arg
)))
709 ;;; We support both the stdcall and cdecl calling conventions on win32 by
710 ;;; resetting ESP after the foreign function returns. This way it works
711 ;;; correctly whether the party that is supposed to pop arguments from
712 ;;; the stack is the caller (cdecl) or the callee (stdcall).
713 (defoptimizer (%alien-funcall ir2-convert
)
714 ((function type
&rest args
) call block
)
715 (let ((type (if (constant-lvar-p type
)
717 (error "Something is broken.")))
718 (lvar (node-lvar call
))
719 ;; KLUDGE: On ARM systems our register pressure is so high
720 ;; that if we process register args before stack args we end
721 ;; up with all of our non-descriptor regs either
722 ;; component-live (NFP) or wired (everything else) and can't
723 ;; actually process the stack args. Processing the arguments
724 ;; in reverse order here doesn't change the semantics, but we
725 ;; deal with all of the stack arguments before the wired
726 ;; register arguments become live.
727 (args #!-arm args
#!+arm
(reverse args
))
728 #!+c-stack-is-control-stack
729 (stack-pointer (make-stack-pointer-tn)))
730 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns
)
731 (make-call-out-tns type
)
733 (vop set-fpu-word-for-c call block
)
734 ;; Save the stack pointer, it will get aligned and subtracting
735 ;; the size will not restore the original value, and some
736 ;; things, like SB-C::CALL-VARIABLE, use the stack pointer to
737 ;; calculate the number of saved values.
738 ;; See alien.impure.lisp/:stack-misalignment
739 #!+c-stack-is-control-stack
740 (vop current-stack-pointer call block stack-pointer
)
741 (vop alloc-number-stack-space call block stack-frame-size nsp
)
742 ;; KLUDGE: This is where the second half of the ARM
743 ;; register-pressure change lives (see above).
744 (dolist (tn #!-arm arg-tns
#!+arm
(reverse arg-tns
))
745 ;; On PPC, TN might be a list. This is used to indicate
746 ;; something special needs to happen. See below.
748 ;; FIXME: We should implement something better than this.
749 (let* ((first-tn (if (listp tn
) (car tn
) tn
))
751 (sc (tn-sc first-tn
))
753 (move-arg-vops (svref (sc-move-arg-vops sc
) scn
)))
755 (unless (= (length move-arg-vops
) 1)
756 (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc
)))
757 #!+(or x86 x86-64
) (emit-move-arg-template call
759 (first move-arg-vops
)
760 (lvar-tn call block arg
)
766 ((and (proper-list-of-length-p tn
3)
767 (symbolp (third tn
)))
768 (emit-template call block
769 (template-or-lose (third tn
))
770 (reference-tn (lvar-tn call block arg
) nil
)
771 (reference-tn-list (butlast tn
) t
)))
773 (let ((temp-tn (make-representation-tn
774 (tn-primitive-type first-tn
) scn
)))
777 (lvar-tn call block arg
)
779 (emit-move-arg-template call
781 (first move-arg-vops
)
787 ;; This means that we have a float arg that we need to
788 ;; also copy to some int regs. The list contains the TN
789 ;; for the float as well as the TNs to use for the int
791 (destructuring-bind (float-tn i1-tn
&optional i2-tn
)
794 (vop sb
!vm
::move-double-to-int-arg call block
795 float-tn i1-tn i2-tn
)
796 (vop sb
!vm
::move-single-to-int-arg call block
799 (let ((result-tns (ensure-list result-tns
)))
800 (vop* call-out call block
801 ((lvar-tn call block function
)
802 (reference-tn-list (remove-if-not #'tn-p
(flatten-list arg-tns
)) nil
))
803 ((reference-tn-list (remove-if-not #'tn-p result-tns
) t
)))
804 #!-c-stack-is-control-stack
805 (vop dealloc-number-stack-space call block stack-frame-size
)
806 #!+c-stack-is-control-stack
807 (vop reset-stack-pointer call block stack-pointer
)
809 (vop set-fpu-word-for-lisp call block
)
813 (proper-list-of-length-p result-tns
3)
814 (symbolp (third result-tns
)))
815 (emit-template call block
816 (template-or-lose (third result-tns
))
817 (reference-tn-list (butlast result-tns
) nil
)
818 (reference-tn (car (ir2-lvar-locs (lvar-info lvar
))) t
)))
820 (move-lvar-result call block result-tns lvar
)))))))