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 extract-alien-value (system-area-pointer unsigned-byte alien-type) t
66 (defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t
69 (defknown alien-funcall (alien-value &rest *) *
72 (defknown alien-funcall-stdcall (alien-value &rest *) *
75 ;;;; cosmetic transforms
77 (deftransform slot ((object slot)
78 ((alien (* t)) symbol))
79 '(slot (deref object) slot))
81 (deftransform %set-slot ((object slot value)
82 ((alien (* t)) symbol t))
83 '(%set-slot (deref object) slot value))
85 (deftransform %slot-addr ((object slot)
86 ((alien (* t)) symbol))
87 '(%slot-addr (deref object) slot))
91 (defun find-slot-offset-and-type (alien slot)
92 (unless (constant-lvar-p slot)
93 (give-up-ir1-transform
94 "The slot is not constant, so access cannot be open coded."))
95 (let ((type (lvar-type alien)))
96 (unless (alien-type-type-p type)
97 (give-up-ir1-transform))
98 (let ((alien-type (alien-type-type-alien-type type)))
99 (unless (alien-record-type-p alien-type)
100 (give-up-ir1-transform))
101 (let* ((slot-name (lvar-value slot))
102 (field (find slot-name (alien-record-type-fields alien-type)
103 :key #'alien-record-field-name)))
105 (abort-ir1-transform "~S doesn't have a slot named ~S"
108 (values (alien-record-field-offset field)
109 (alien-record-field-type field))))))
111 #+nil ;; Shouldn't be necessary.
112 (defoptimizer (slot derive-type) ((alien slot))
114 (catch 'give-up-ir1-transform
115 (multiple-value-bind (slot-offset slot-type)
116 (find-slot-offset-and-type alien slot)
117 (declare (ignore slot-offset))
118 (return (make-alien-type-type slot-type))))
121 (deftransform slot ((alien slot) * * :important t)
122 (multiple-value-bind (slot-offset slot-type)
123 (find-slot-offset-and-type alien slot)
124 `(extract-alien-value (alien-sap alien)
128 #+nil ;; ### But what about coercions?
129 (defoptimizer (%set-slot derive-type) ((alien slot value))
131 (catch 'give-up-ir1-transform
132 (multiple-value-bind (slot-offset slot-type)
133 (find-slot-offset-and-type alien slot)
134 (declare (ignore slot-offset))
135 (let ((type (make-alien-type-type slot-type)))
136 (assert-lvar-type value type)
140 (deftransform %set-slot ((alien slot value) * * :important t)
141 (multiple-value-bind (slot-offset slot-type)
142 (find-slot-offset-and-type alien slot)
143 `(deposit-alien-value (alien-sap alien)
148 (defoptimizer (%slot-addr derive-type) ((alien slot))
150 (catch 'give-up-ir1-transform
151 (multiple-value-bind (slot-offset slot-type)
152 (find-slot-offset-and-type alien slot)
153 (declare (ignore slot-offset))
154 (return (make-alien-type-type
155 (make-alien-pointer-type :to slot-type)))))
158 (deftransform %slot-addr ((alien slot) * * :important t)
159 (multiple-value-bind (slot-offset slot-type)
160 (find-slot-offset-and-type alien slot)
161 (/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
162 `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:n-byte-bits))
163 ',(make-alien-pointer-type :to slot-type))))
167 (defun find-deref-alien-type (alien)
168 (let ((alien-type (lvar-type alien)))
169 (unless (alien-type-type-p alien-type)
170 (give-up-ir1-transform))
171 (let ((alien-type (alien-type-type-alien-type alien-type)))
172 (if (alien-type-p alien-type)
174 (give-up-ir1-transform)))))
176 (defun find-deref-element-type (alien)
177 (let ((alien-type (find-deref-alien-type alien)))
180 (alien-pointer-type-to alien-type))
182 (alien-array-type-element-type alien-type))
184 (give-up-ir1-transform)))))
186 (defun compute-deref-guts (alien indices)
187 (let ((alien-type (find-deref-alien-type alien)))
191 (abort-ir1-transform "too many indices for pointer deref: ~W"
193 (let ((element-type (alien-pointer-type-to alien-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 (extract-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 (deposit-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) * * :important t)
307 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
308 `(extract-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 `(deposit-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 ',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)
352 #!+(or x86 x86-64) `(truly-the system-area-pointer
353 (%primitive alloc-alien-stack-space
354 ,(ceiling (alien-type-bits alien-type)
356 #!-(or x86 x86-64) `(truly-the system-area-pointer
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 (extract-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 extract-alien-value ((sap offset type) * * :important t)
513 (%computed-lambda #'compute-extract-lambda type))
514 (deftransform deposit-alien-value ((sap offset type value) * * :important t)
515 (%computed-lambda #'compute-deposit-lambda type)))
517 ;;;; a hack to clean up divisions
519 (defun count-low-order-zeros (thing)
522 (if (constant-lvar-p thing)
523 (count-low-order-zeros (lvar-value thing))
524 (count-low-order-zeros (lvar-uses thing))))
526 (case (let ((name (lvar-fun-name (combination-fun thing))))
527 (or (modular-version-info name :unsigned) name))
529 (let ((min most-positive-fixnum)
530 (itype (specifier-type 'integer)))
531 (dolist (arg (combination-args thing) min)
532 (if (csubtypep (lvar-type arg) itype)
533 (setf min (min min (count-low-order-zeros arg)))
537 (itype (specifier-type 'integer)))
538 (dolist (arg (combination-args thing) result)
539 (if (csubtypep (lvar-type arg) itype)
540 (setf result (+ result (count-low-order-zeros arg)))
543 (let ((args (combination-args thing)))
544 (if (= (length args) 2)
545 (let ((amount (second args)))
546 (if (constant-lvar-p amount)
547 (max (+ (count-low-order-zeros (first args))
557 (do ((result 0 (1+ result))
558 (num thing (ash num -1)))
559 ((logbitp 0 num) result))))
561 (count-low-order-zeros (cast-value thing)))
565 (deftransform / ((numerator denominator) (integer integer))
566 "convert x/2^k to shift"
567 (unless (constant-lvar-p denominator)
568 (give-up-ir1-transform))
569 (let* ((denominator (lvar-value denominator))
570 (bits (1- (integer-length denominator))))
571 (unless (and (> denominator 0) (= (ash 1 bits) denominator))
572 (give-up-ir1-transform))
573 (let ((alignment (count-low-order-zeros numerator)))
574 (unless (>= alignment bits)
575 (give-up-ir1-transform))
576 `(ash numerator ,(- bits)))))
578 (deftransform ash ((value amount))
579 (let ((value-node (lvar-uses value)))
580 (unless (combination-p value-node)
581 (give-up-ir1-transform))
582 (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
583 (multiple-value-bind (prototype width)
584 (modular-version-info inside-fun-name :unsigned)
585 (unless (eq (or prototype inside-fun-name) 'ash)
586 (give-up-ir1-transform))
587 (when (and width (not (constant-lvar-p amount)))
588 (give-up-ir1-transform))
589 (let ((inside-args (combination-args value-node)))
590 (unless (= (length inside-args) 2)
591 (give-up-ir1-transform))
592 (let ((inside-amount (second inside-args)))
593 (unless (and (constant-lvar-p inside-amount)
594 (not (minusp (lvar-value inside-amount))))
595 (give-up-ir1-transform)))
596 (extract-fun-args value inside-fun-name 2)
598 `(lambda (value amount1 amount2)
599 (logand (ash value (+ amount1 amount2))
600 ,(1- (ash 1 (+ width (lvar-value amount))))))
601 `(lambda (value amount1 amount2)
602 (ash value (+ amount1 amount2)))))))))
604 ;;;; ALIEN-FUNCALL support
606 (deftransform alien-funcall ((function &rest args)
607 ((alien (* t)) &rest *) *
609 (let ((names (make-gensym-list (length args))))
610 (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
611 `(lambda (function ,@names)
612 (alien-funcall (deref function) ,@names))))
614 (deftransform alien-funcall ((function &rest args) * * :important t)
615 (let ((type (lvar-type function)))
616 (unless (alien-type-type-p type)
617 (give-up-ir1-transform "can't tell function type at compile time"))
618 (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
619 (let ((alien-type (alien-type-type-alien-type type)))
620 (unless (alien-fun-type-p alien-type)
621 (give-up-ir1-transform))
622 (let ((arg-types (alien-fun-type-arg-types alien-type)))
623 (unless (= (length args) (length arg-types))
625 "wrong number of arguments; expected ~W, got ~W"
628 (collect ((params) (deports))
629 (dolist (arg-type arg-types)
630 (let ((param (gensym)))
632 (deports `(deport ,param ',arg-type))))
633 (let ((return-type (alien-fun-type-result-type alien-type))
634 (body `(%alien-funcall (deport function ',alien-type)
637 (if (alien-values-type-p return-type)
638 (collect ((temps) (results))
639 (dolist (type (alien-values-type-values return-type))
640 (let ((temp (gensym)))
642 (results `(naturalize ,temp ',type))))
644 `(multiple-value-bind ,(temps) ,body
645 (values ,@(results)))))
646 (setf body `(naturalize ,body ',return-type)))
647 (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
648 `(lambda (function ,@(params))
651 (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
652 (declare (ignore function args))
653 (unless (constant-lvar-p type)
654 (error "Something is broken."))
655 (let ((type (lvar-value type)))
656 (unless (alien-fun-type-p type)
657 (error "Something is broken."))
658 (values-specifier-type
659 (compute-alien-rep-type
660 (alien-fun-type-result-type type)))))
662 (defoptimizer (%alien-funcall ltn-annotate)
663 ((function type &rest args) node ltn-policy)
664 (setf (basic-combination-info node) :funny)
665 (setf (node-tail-p node) nil)
666 (annotate-ordinary-lvar function)
668 (annotate-ordinary-lvar arg)))
670 (defoptimizer (%alien-funcall ir2-convert)
671 ((function type &rest args) call block)
672 (let ((type (if (constant-lvar-p type)
674 (error "Something is broken.")))
675 (lvar (node-lvar call))
677 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
678 (make-call-out-tns type)
679 (vop alloc-number-stack-space call block stack-frame-size nsp)
681 ;; On PPC, TN might be a list. This is used to indicate
682 ;; something special needs to happen. See below.
684 ;; FIXME: We should implement something better than this.
685 (let* ((first-tn (if (listp tn) (car tn) tn))
687 (sc (tn-sc first-tn))
689 #!-(or x86 x86-64) (temp-tn (make-representation-tn
690 (tn-primitive-type first-tn) scn))
691 (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
693 (unless (= (length move-arg-vops) 1)
694 (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
695 #!+(or x86 x86-64) (emit-move-arg-template call
697 (first move-arg-vops)
698 (lvar-tn call block arg)
701 #!-(or x86 x86-64) (progn
704 (lvar-tn call block arg)
706 (emit-move-arg-template call
708 (first move-arg-vops)
714 ;; This means that we have a float arg that we need to
715 ;; also copy to some int regs. The list contains the TN
716 ;; for the float as well as the TNs to use for the int
718 (destructuring-bind (float-tn i1-tn &optional i2-tn)
721 (vop sb!vm::move-double-to-int-arg call block
722 float-tn i1-tn i2-tn)
723 (vop sb!vm::move-single-to-int-arg call block
726 (unless (listp result-tns)
727 (setf result-tns (list result-tns)))
728 (let ((arg-tns (flatten-list arg-tns)))
729 (vop* call-out call block
730 ((lvar-tn call block function)
731 (reference-tn-list arg-tns nil))
732 ((reference-tn-list result-tns t))))
733 (vop dealloc-number-stack-space call block stack-frame-size)
734 (move-lvar-result call block result-tns lvar))))
736 ;;;; ALIEN-FUNCALL-STDCALL support
739 (deftransform alien-funcall-stdcall ((function &rest args)
740 ((alien (* t)) &rest *) *
742 (let ((names (make-gensym-list (length args))))
743 (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL-STDCALL" function args)
744 `(lambda (function ,@names)
745 (alien-funcall-stdcall (deref function) ,@names))))
748 (deftransform alien-funcall-stdcall ((function &rest args) * * :important t)
749 (let ((type (lvar-type function)))
750 (unless (alien-type-type-p type)
751 (give-up-ir1-transform "can't tell function type at compile time"))
752 (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL-STDCALL" function)
753 (let ((alien-type (alien-type-type-alien-type type)))
754 (unless (alien-fun-type-p alien-type)
755 (give-up-ir1-transform))
756 (let ((arg-types (alien-fun-type-arg-types alien-type)))
757 (unless (= (length args) (length arg-types))
759 "wrong number of arguments; expected ~W, got ~W"
762 (collect ((params) (deports))
763 (dolist (arg-type arg-types)
764 (let ((param (gensym)))
766 (deports `(deport ,param ',arg-type))))
767 (let ((return-type (alien-fun-type-result-type alien-type))
768 (body `(%alien-funcall-stdcall (deport function ',alien-type)
771 (if (alien-values-type-p return-type)
772 (collect ((temps) (results))
773 (dolist (type (alien-values-type-values return-type))
774 (let ((temp (gensym)))
776 (results `(naturalize ,temp ',type))))
778 `(multiple-value-bind ,(temps) ,body
779 (values ,@(results)))))
780 (setf body `(naturalize ,body ',return-type)))
781 (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL-STDCALL" (params) body)
782 `(lambda (function ,@(params))
786 (defoptimizer (%alien-funcall-stdcall derive-type) ((function type &rest args))
787 (declare (ignore function args))
788 (unless (constant-lvar-p type)
789 (error "Something is broken."))
790 (let ((type (lvar-value type)))
791 (unless (alien-fun-type-p type)
792 (error "Something is broken."))
793 (values-specifier-type
794 (compute-alien-rep-type
795 (alien-fun-type-result-type type)))))
798 (defoptimizer (%alien-funcall-stdcall ltn-annotate)
799 ((function type &rest args) node ltn-policy)
800 (setf (basic-combination-info node) :funny)
801 (setf (node-tail-p node) nil)
802 (annotate-ordinary-lvar function)
804 (annotate-ordinary-lvar arg)))
807 (defoptimizer (%alien-funcall-stdcall ir2-convert)
808 ((function type &rest args) call block)
809 (let ((type (if (constant-lvar-p type)
811 (error "Something is broken.")))
812 (lvar (node-lvar call))
814 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
815 (make-call-out-tns type)
816 (vop alloc-number-stack-space call block stack-frame-size nsp)
818 (let* ((arg (pop args))
821 #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
823 (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
825 (unless (= (length move-arg-vops) 1)
826 (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
827 #!+x86 (emit-move-arg-template call
829 (first move-arg-vops)
830 (lvar-tn call block arg)
836 (lvar-tn call block arg)
838 (emit-move-arg-template call
840 (first move-arg-vops)
845 (unless (listp result-tns)
846 (setf result-tns (list result-tns)))
847 (vop* call-out call block
848 ((lvar-tn call block function)
849 (reference-tn-list arg-tns nil))
850 ((reference-tn-list result-tns t)))
851 ;; This is the stdcall magic: Callee clears args.
852 #+nil (vop dealloc-number-stack-space call block stack-frame-size)
853 (move-lvar-result call block result-tns lvar))))