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
))
55 (defknown %cast
(alien-value alien-type
) alien
58 (defknown naturalize
(t alien-type
) alien
60 (defknown deport
(alien alien-type
) t
62 (defknown deport-alloc
(alien alien-type
) t
64 (defknown %alien-value
(system-area-pointer word alien-type
) t
66 (defknown (setf %alien-value
) (t system-area-pointer word alien-type
) t
69 (defknown alien-funcall
(alien-value &rest t
) *
72 (defknown sb-alien
::string-to-c-string
(simple-string t
) (or (simple-array (unsigned-byte 8) (*))
75 (defknown sb-alien
::c-string-to-string
(system-area-pointer t t
) simple-string
77 (defknown sb-alien
::c-string-external-format
* *
80 ;;;; cosmetic transforms
82 (deftransform slot
((object slot
)
83 ((alien (* t
)) symbol
))
84 '(slot (deref object
) slot
))
86 (deftransform %set-slot
((object slot value
)
87 ((alien (* t
)) symbol t
))
88 '(%set-slot
(deref object
) slot value
))
90 (deftransform %slot-addr
((object slot
)
91 ((alien (* t
)) symbol
))
92 '(%slot-addr
(deref object
) slot
))
96 (defun find-slot-offset-and-type (alien slot
)
97 (unless (constant-lvar-p slot
)
98 (give-up-ir1-transform
99 "The slot is not constant, so access cannot be open coded."))
100 (let ((type (lvar-type alien
)))
101 (unless (alien-type-type-p type
)
102 (give-up-ir1-transform))
103 (let ((alien-type (alien-type-type-alien-type type
)))
104 (unless (alien-record-type-p alien-type
)
105 (give-up-ir1-transform))
106 (let* ((slot-name (lvar-value slot
))
107 (field (find slot-name
(alien-record-type-fields alien-type
)
108 :key
#'alien-record-field-name
)))
110 (abort-ir1-transform "~S~% doesn't have a slot named ~S"
112 (values (alien-record-field-offset field
)
113 (alien-record-field-type field
))))))
115 #+nil
;; Shouldn't be necessary.
116 (defoptimizer (slot derive-type
) ((alien slot
))
118 (catch 'give-up-ir1-transform
119 (multiple-value-bind (slot-offset slot-type
)
120 (find-slot-offset-and-type alien slot
)
121 (declare (ignore slot-offset
))
122 (return (make-alien-type-type slot-type
))))
125 (deftransform slot
((alien slot
))
126 (multiple-value-bind (slot-offset slot-type
)
127 (find-slot-offset-and-type alien slot
)
128 `(%alien-value
(alien-sap alien
)
132 #+nil
;; ### But what about coercions?
133 (defoptimizer (%set-slot derive-type
) ((alien slot value
))
135 (catch 'give-up-ir1-transform
136 (multiple-value-bind (slot-offset slot-type
)
137 (find-slot-offset-and-type alien slot
)
138 (declare (ignore slot-offset
))
139 (let ((type (make-alien-type-type slot-type
)))
140 (assert-lvar-type value type
)
144 (deftransform %set-slot
((alien slot value
))
145 (multiple-value-bind (slot-offset slot-type
)
146 (find-slot-offset-and-type alien slot
)
147 `(setf (%alien-value
(alien-sap alien
)
152 (defoptimizer (%slot-addr derive-type
) ((alien slot
))
154 (catch 'give-up-ir1-transform
155 (multiple-value-bind (slot-offset slot-type
)
156 (find-slot-offset-and-type alien slot
)
157 (declare (ignore slot-offset
))
158 (return (make-alien-type-type
159 (make-alien-pointer-type :to slot-type
)))))
162 (deftransform %slot-addr
((alien slot
))
163 (multiple-value-bind (slot-offset slot-type
)
164 (find-slot-offset-and-type alien slot
)
165 (/noshow
"in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
166 `(%sap-alien
(sap+ (alien-sap alien
) (/ ,slot-offset sb-vm
:n-byte-bits
))
167 ',(make-alien-pointer-type :to slot-type
))))
171 (defun find-deref-alien-type (alien)
172 (let ((alien-type (lvar-type alien
)))
173 (unless (alien-type-type-p alien-type
)
174 (give-up-ir1-transform))
175 (alien-type-type-alien-type alien-type
)))
177 (defun find-deref-element-type (alien)
178 (let ((alien-type (find-deref-alien-type alien
)))
181 (alien-pointer-type-to alien-type
))
183 (alien-array-type-element-type alien-type
))
185 (give-up-ir1-transform)))))
187 (defun compute-deref-guts (alien indices
)
188 (let ((alien-type (find-deref-alien-type alien
)))
192 (abort-ir1-transform "too many indices for pointer deref: ~W"
194 (let ((element-type (alien-pointer-type-to alien-type
)))
196 (give-up-ir1-transform "unable to open code deref of wild pointer type"))
198 (let ((bits (alien-type-bits element-type
))
199 (alignment (alien-type-alignment element-type
)))
201 (abort-ir1-transform "unknown element size"))
203 (abort-ir1-transform "unknown element alignment"))
206 ,(align-offset bits alignment
))
208 (values nil
0 element-type
))))
210 (let* ((element-type (alien-array-type-element-type alien-type
))
211 (bits (alien-type-bits element-type
))
212 (alignment (alien-type-alignment element-type
))
213 (dims (alien-array-type-dimensions alien-type
)))
214 (unless (= (length indices
) (length dims
))
215 (give-up-ir1-transform "incorrect number of indices"))
217 (give-up-ir1-transform "Element size is unknown."))
219 (give-up-ir1-transform "Element alignment is unknown."))
221 (values nil
0 element-type
)
222 (let* ((arg (gensym))
225 (dolist (dim (cdr dims
))
226 (let ((arg (gensym)))
228 (setf offsetexpr
`(+ (* ,offsetexpr
,dim
) ,arg
))))
229 (values (reverse args
)
231 ,(align-offset bits alignment
))
234 (abort-ir1-transform "~S not either a pointer or array type."
237 #+nil
;; Shouldn't be necessary.
238 (defoptimizer (deref derive-type
) ((alien &rest noise
))
240 (catch 'give-up-ir1-transform
241 (return (make-alien-type-type (find-deref-element-type alien
))))
244 (deftransform deref
((alien &rest indices
))
245 (multiple-value-bind (indices-args offset-expr element-type
)
246 (compute-deref-guts alien indices
)
247 `(lambda (alien ,@indices-args
)
248 (%alien-value
(alien-sap alien
)
252 #+nil
;; ### Again, the value might be coerced.
253 (defoptimizer (%set-deref derive-type
) ((alien value
&rest noise
))
255 (catch 'give-up-ir1-transform
256 (let ((type (make-alien-type-type
257 (make-alien-pointer-type
258 :to
(find-deref-element-type alien
)))))
259 (assert-lvar-type value type
)
263 (deftransform %set-deref
((alien value
&rest indices
))
264 (multiple-value-bind (indices-args offset-expr element-type
)
265 (compute-deref-guts alien indices
)
266 `(lambda (alien value
,@indices-args
)
267 (setf (%alien-value
(alien-sap alien
)
272 (defoptimizer (%deref-addr derive-type
) ((alien &rest 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
))
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
)) *)
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 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))
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))
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
))
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
))
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))
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
))
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 (if (constant-lvar-p info
)
415 (let* ((info (lvar-value info
))
416 (alien-type (local-alien-info-type info
)))
417 (make-alien-type-type (make-alien-pointer-type :to alien-type
)))
420 (deftransform %local-alien-addr
((info var
))
421 (alien-info-constant-or-abort info
)
422 (let* ((info (lvar-value info
))
423 (alien-type (local-alien-info-type info
)))
424 (/noshow
"in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
425 (if (local-alien-info-force-to-memory-p info
)
426 `(%sap-alien var
',(make-alien-pointer-type :to alien-type
))
427 (error "This shouldn't happen."))))
431 (defoptimizer (%cast derive-type
) ((alien type
))
432 (or (when (constant-lvar-p type
)
433 (let ((alien-type (lvar-value type
)))
434 (when (alien-type-p alien-type
)
435 (make-alien-type-type alien-type
))))
438 (deftransform %cast
((alien target-type
))
439 (unless (constant-lvar-p target-type
)
440 (give-up-ir1-transform
441 "The alien type is not constant, so access cannot be open coded."))
442 (let ((target-type (lvar-value target-type
)))
443 (cond ((or (alien-pointer-type-p target-type
)
444 (alien-array-type-p target-type
)
445 (alien-fun-type-p target-type
))
446 `(naturalize (alien-sap alien
) ',target-type
))
448 (abort-ir1-transform "cannot cast to alien type ~S" target-type
)))))
450 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
452 (deftransform alien-sap
((alien))
453 (let ((alien-node (lvar-uses alien
)))
456 (splice-fun-args alien
'%sap-alien
2)
458 (declare (ignore type
))
461 (give-up-ir1-transform)))))
463 (defoptimizer (%sap-alien derive-type
) ((sap type
))
464 (if (constant-lvar-p type
)
465 (make-alien-type-type (lvar-value type
))
468 (deftransform %sap-alien
((sap type
))
469 "optimize away %SAP-ALIEN"
470 (give-up-ir1-transform
471 "forced to do runtime allocation of alien-value structure"))
473 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
475 (flet ((%computed-lambda
(compute-lambda type
)
476 (declare (type function compute-lambda
))
477 (unless (constant-lvar-p type
)
478 (give-up-ir1-transform
479 "The type is not constant at compile time; can't open code."))
481 (let ((result (funcall compute-lambda
(lvar-value type
))))
482 (/noshow
"in %COMPUTED-LAMBDA" (lvar-value type
) result
)
485 (compiler-error "~A" condition
)))))
486 (deftransform naturalize
((object type
))
487 (%computed-lambda
#'compute-naturalize-lambda type
))
488 (deftransform deport
((alien type
))
489 (%computed-lambda
#'compute-deport-lambda type
))
490 (deftransform deport-alloc
((alien type
))
491 (%computed-lambda
#'compute-deport-alloc-lambda type
))
492 (deftransform %alien-value
((sap offset type
))
493 (%computed-lambda
#'compute-extract-lambda type
))
494 (deftransform (setf %alien-value
) ((value sap offset type
))
495 (%computed-lambda
#'compute-deposit-lambda type
)))
497 ;;;; ALIEN-FUNCALL support
499 (deftransform alien-funcall
((function &rest args
)
500 ((alien (* t
)) &rest t
) *)
501 (let ((names (make-gensym-list (length args
))))
502 (/noshow
"entering first DEFTRANSFORM ALIEN-FUNCALL" function args
)
503 `(lambda (function ,@names
)
504 (alien-funcall (deref function
) ,@names
))))
506 (deftransform alien-funcall
((function &rest args
) * * :node node
)
507 (let ((type (lvar-type function
)))
508 (unless (alien-type-type-p type
)
509 (give-up-ir1-transform "can't tell function type at compile time"))
510 (/noshow
"entering second DEFTRANSFORM ALIEN-FUNCALL" function
)
511 (let ((alien-type (alien-type-type-alien-type type
)))
512 (unless (alien-fun-type-p alien-type
)
513 (give-up-ir1-transform))
514 (let ((arg-types (alien-fun-type-arg-types alien-type
))
516 (unless (= (length args
) (length arg-types
))
518 "wrong number of arguments; expected ~W, got ~W"
521 (collect ((params) (deports))
522 (dolist (arg-type arg-types
)
523 (let ((param (gensym)))
525 (deports `(deport ,param
',arg-type
))))
526 ;; Build BODY from the inside out.
527 (let ((return-type (alien-fun-type-result-type alien-type
))
528 ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
529 ;; to them) and do the call.
531 ;; If FUNCTION's source looks like
532 ;; (%SAP-ALIEN (FOREIGN-SYMBOL-SAP "sym") #<anything>)
533 ;; then snarf out the string and use it as the funarg
534 ;; unless the backend lacks the CALL-OUT-NAMED vop.
536 ,(or (when-vop-existsp (:named call-out-named
)
537 (when (lvar-matches function
:fun-names
'(%sap-alien
)
539 (let ((sap (first (combination-args (lvar-use function
)))))
540 (when (lvar-matches sap
:fun-names
'(foreign-symbol-sap)
542 (let ((sym (first (combination-args (lvar-use sap
)))))
543 (when (and (constant-lvar-p sym
)
544 (stringp (lvar-value sym
)))
546 (lvar-value sym
)))))))
547 `(deport function
',alien-type
))
550 ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
551 ;; the SAPs are taken for won't be moved by the GC. (If
552 ;; needed: some alien types won't need it).
553 (setf body
`(maybe-with-pinned-objects ,(params) ,arg-types
555 ;; Around that handle any memory allocation that's needed.
556 ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
557 ;; identity operation, but for example for deporting a
558 ;; Unicode string we need to convert the string into an
559 ;; octet array. This step needs to be done before the pinning
560 ;; to ensure we pin the right objects, so it can't be combined
561 ;; with the deporting.
563 (loop for param in
(params)
564 for arg-type in arg-types
566 `(let ((,param
(deport-alloc ,param
',arg-type
)))
568 (if (alien-values-type-p return-type
)
569 (collect ((temps) (results))
570 (dolist (type (alien-values-type-values return-type
))
571 (let ((temp (gensym)))
573 (results `(naturalize ,temp
',type
))))
575 `(multiple-value-bind ,(temps) ,body
576 (values ,@(results)))))
577 (setf body
`(naturalize ,body
',return-type
)))
578 ;; Remember this frame to make sure that we can get back
579 ;; to it later regardless of how the foreign stack looks
581 #+c-stack-is-control-stack
582 (when (policy node
(= 3 alien-funcall-saves-fp-and-pc
))
583 (setf body
`(invoke-with-saved-fp (lambda () ,body
))))
584 (/noshow
"returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body
)
585 `(lambda (function ,@(params))
586 ,@(when ignore-fun
'((declare (ignore function
))))
587 (declare (optimize (let-conversion 3)))
590 (defoptimizer (%alien-funcall derive-type
) ((function type
&rest args
))
591 (unless (and (constant-lvar-p type
)
592 (alien-fun-type-p (lvar-value type
)))
593 (error "Something is broken."))
594 (let ((spec (compute-alien-rep-type
595 (alien-fun-type-result-type (lvar-value type
))
597 (if (eq spec
'*) *wild-type
* (values-specifier-type spec
))))
599 (defoptimizer (%alien-funcall ltn-annotate
)
600 ((function type
&rest args
) node
)
601 (setf (basic-combination-info node
) :funny
)
602 (setf (node-tail-p node
) nil
)
603 (unless (and (constant-lvar-p function
)
605 (annotate-ordinary-lvar function
))
607 (annotate-ordinary-lvar arg
)))
609 ;;; We support both the stdcall and cdecl calling conventions on win32 by
610 ;;; resetting ESP after the foreign function returns. This way it works
611 ;;; correctly whether the party that is supposed to pop arguments from
612 ;;; the stack is the caller (cdecl) or the callee (stdcall).
613 (defoptimizer (%alien-funcall ir2-convert
)
614 ((function type
&rest args
) call block
)
615 (let ((type (if (constant-lvar-p type
)
617 (error "Something is broken.")))
618 (lvar (node-lvar call
))
619 ;; KLUDGE: On ARM systems our register pressure is so high
620 ;; that if we process register args before stack args we end
621 ;; up with all of our non-descriptor regs either
622 ;; component-live (NFP) or wired (everything else) and can't
623 ;; actually process the stack args. Processing the arguments
624 ;; in reverse order here doesn't change the semantics, but we
625 ;; deal with all of the stack arguments before the wired
626 ;; register arguments become live.
627 (args #-arm args
#+arm
(reverse args
))
628 #+c-stack-is-control-stack
629 (stack-pointer (make-stack-pointer-tn)))
630 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns
)
631 (make-call-out-tns type
)
633 (vop set-fpu-word-for-c call block
)
634 ;; Save the stack pointer, it will get aligned and subtracting
635 ;; the size will not restore the original value, and some
636 ;; things, like SB-C::CALL-VARIABLE, use the stack pointer to
637 ;; calculate the number of saved values.
638 ;; See alien.impure.lisp/:stack-misalignment
639 #+c-stack-is-control-stack
640 (vop current-stack-pointer call block stack-pointer
)
641 (vop alloc-number-stack-space call block stack-frame-size nsp
)
642 ;; KLUDGE: This is where the second half of the ARM
643 ;; register-pressure change lives (see above).
644 (dolist (tn #-arm arg-tns
#+arm
(reverse arg-tns
))
646 (funcall tn
(pop args
) call block nsp
)
647 ;; On PPC, TN might be a list. This is used to indicate
648 ;; something special needs to happen. See below.
650 ;; FIXME: We should implement something better than this.
651 (let* ((first-tn (if (listp tn
) (car tn
) tn
))
653 (sc (tn-sc first-tn
))
655 (move-arg-vops (svref (sc-move-arg-vops sc
) scn
)))
657 (unless (= (length move-arg-vops
) 1)
658 (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc
)))
663 (symbolp (car (last tn
))))
664 (emit-template call block
665 (template-or-lose (car (last tn
)))
666 (reference-tn (lvar-tn call block arg
) nil
)
667 (reference-tn-list (butlast tn
) t
)))
669 (when (eq (sb-kind (sc-sb sc
)) :unbounded
) ;; stacks are unbounded
670 ;; Avoid allocating this TN on the caller's stack
671 (setf (tn-kind first-tn
) :arg-pass
))
673 (emit-move-arg-template call
675 (first move-arg-vops
)
676 (lvar-tn call block arg
)
680 (let* ((primitive-type (tn-primitive-type first-tn
))
681 ;; If the destination is a stack TN make sure
682 ;; the temporary TN is a register.
683 (scn (if (sc-number-stack-p sc
)
684 (car (primitive-type-scs primitive-type
))
686 (temp-tn (make-representation-tn primitive-type scn
)))
687 (emit-move call block
(lvar-tn call block arg
) temp-tn
)
688 (emit-move-arg-template call
690 (first move-arg-vops
)
696 ;; This means that we have a float arg that we need to
697 ;; also copy to some int regs. The list contains the TN
698 ;; for the float as well as the TNs to use for the int
700 (destructuring-bind (float-tn i1-tn
&optional i2-tn
)
703 (vop sb-vm
::move-double-to-int-arg call block
704 float-tn i1-tn i2-tn
)
705 (vop sb-vm
::move-single-to-int-arg call block
706 float-tn i1-tn
)))))))
708 (let* ((result-tns (ensure-list result-tns
))
710 (reference-tn-list (remove-if-not #'tn-p
(flatten-list arg-tns
)) nil
))
712 (reference-tn-list (remove-if-not #'tn-p result-tns
) t
)))
713 (cond #+#.
(cl:if
(sb-c::vop-existsp
:named sb-vm
::call-out-named
) '(and) '(or))
714 ((and (constant-lvar-p function
) (stringp (lvar-value function
)))
715 (vop* call-out-named call block
(arg-operands) (result-operands)
716 (lvar-value function
)
717 (sb-alien::alien-fun-type-varargs type
)))
719 (vop* call-out call block
720 ((lvar-tn call block function
) arg-operands
)
722 #-c-stack-is-control-stack
723 (vop dealloc-number-stack-space call block stack-frame-size
)
724 #+c-stack-is-control-stack
725 (vop reset-stack-pointer call block stack-pointer
)
727 (vop set-fpu-word-for-lisp call block
)
731 (symbolp (car (last result-tns
))))
732 (emit-template call block
733 (template-or-lose (car (last result-tns
)))
734 (reference-tn-list (butlast result-tns
2) nil
)
735 (reference-tn (car (last result-tns
2)) t
))
736 (move-lvar-result call block
(list (car (last result-tns
2))) lvar
))
738 (move-lvar-result call block result-tns lvar
)))))))
740 (deftransform sb-alien
::c-string-external-format
((type)
741 ((constant-arg sb-alien
::alien-c-string-type
)))
742 (let ((format (sb-alien::alien-c-string-type-external-format
744 (if (eq format
:default
)
745 `(sb-alien::default-c-string-external-format
)