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.
19 (defknown %sap-alien (system-area-pointer alien-type) alien-value
21 (defknown alien-sap (alien-value) system-area-pointer
24 (defknown slot (alien-value symbol) t
25 (flushable recursive))
26 (defknown %set-slot (alien-value symbol t) t
28 (defknown %slot-addr (alien-value symbol) (alien (* t))
29 (flushable movable recursive))
31 (defknown deref (alien-value &rest index) t
33 (defknown %set-deref (alien-value t &rest index) t
35 (defknown %deref-addr (alien-value &rest index) (alien (* t))
38 (defknown %heap-alien (heap-alien-info) t
40 (defknown %set-heap-alien (heap-alien-info t) t
42 (defknown %heap-alien-addr (heap-alien-info) (alien (* t))
45 (defknown make-local-alien (local-alien-info) t
47 (defknown note-local-alien-type (local-alien-info t) null
49 (defknown local-alien (local-alien-info t) t
51 (defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
53 (defknown %set-local-alien (local-alien-info t t) t
55 (defknown %local-alien-addr (local-alien-info t) (alien (* t))
57 (defknown dispose-local-alien (local-alien-info t) t
60 (defknown %cast (alien-value alien-type) alien
63 (defknown naturalize (t alien-type) alien
65 (defknown deport (alien alien-type) t
67 (defknown extract-alien-value (system-area-pointer index alien-type) t
69 (defknown deposit-alien-value (system-area-pointer index alien-type t) t
72 (defknown alien-funcall (alien-value &rest *) *
74 (defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
76 ;;;; cosmetic transforms
78 (deftransform slot ((object slot)
79 ((alien (* t)) symbol))
80 '(slot (deref object) slot))
82 (deftransform %set-slot ((object slot value)
83 ((alien (* t)) symbol t))
84 '(%set-slot (deref object) slot value))
86 (deftransform %slot-addr ((object slot)
87 ((alien (* t)) symbol))
88 '(%slot-addr (deref object) slot))
92 (defun find-slot-offset-and-type (alien slot)
93 (unless (constant-continuation-p slot)
94 (give-up-ir1-transform
95 "The slot is not constant, so access cannot be open coded."))
96 (let ((type (continuation-type alien)))
97 (unless (alien-type-type-p type)
98 (give-up-ir1-transform))
99 (let ((alien-type (alien-type-type-alien-type type)))
100 (unless (alien-record-type-p alien-type)
101 (give-up-ir1-transform))
102 (let* ((slot-name (continuation-value slot))
103 (field (find slot-name (alien-record-type-fields alien-type)
104 :key #'alien-record-field-name)))
106 (abort-ir1-transform "~S doesn't have a slot named ~S"
109 (values (alien-record-field-offset field)
110 (alien-record-field-type field))))))
112 #+nil ;; Shouldn't be necessary.
113 (defoptimizer (slot derive-type) ((alien slot))
115 (catch 'give-up-ir1-transform
116 (multiple-value-bind (slot-offset slot-type)
117 (find-slot-offset-and-type alien slot)
118 (declare (ignore slot-offset))
119 (return (make-alien-type-type slot-type))))
122 (deftransform slot ((alien slot) * * :important t)
123 (multiple-value-bind (slot-offset slot-type)
124 (find-slot-offset-and-type alien slot)
125 `(extract-alien-value (alien-sap alien)
129 #+nil ;; ### But what about coercions?
130 (defoptimizer (%set-slot derive-type) ((alien slot value))
132 (catch 'give-up-ir1-transform
133 (multiple-value-bind (slot-offset slot-type)
134 (find-slot-offset-and-type alien slot)
135 (declare (ignore slot-offset))
136 (let ((type (make-alien-type-type slot-type)))
137 (assert-continuation-type value type)
141 (deftransform %set-slot ((alien slot value) * * :important t)
142 (multiple-value-bind (slot-offset slot-type)
143 (find-slot-offset-and-type alien slot)
144 `(deposit-alien-value (alien-sap alien)
149 (defoptimizer (%slot-addr derive-type) ((alien slot))
151 (catch 'give-up-ir1-transform
152 (multiple-value-bind (slot-offset slot-type)
153 (find-slot-offset-and-type alien slot)
154 (declare (ignore slot-offset))
155 (return (make-alien-type-type
156 (make-alien-pointer-type :to slot-type)))))
159 (deftransform %slot-addr ((alien slot) * * :important t)
160 (multiple-value-bind (slot-offset slot-type)
161 (find-slot-offset-and-type alien slot)
162 (/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
163 `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:byte-bits))
164 ',(make-alien-pointer-type :to slot-type))))
168 (defun find-deref-alien-type (alien)
169 (let ((alien-type (continuation-type alien)))
170 (unless (alien-type-type-p alien-type)
171 (give-up-ir1-transform))
172 (let ((alien-type (alien-type-type-alien-type alien-type)))
173 (if (alien-type-p alien-type)
175 (give-up-ir1-transform)))))
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: ~D"
194 (let ((element-type (alien-pointer-type-to alien-type)))
196 (let ((bits (alien-type-bits element-type))
197 (alignment (alien-type-alignment element-type)))
199 (abort-ir1-transform "unknown element size"))
201 (abort-ir1-transform "unknown element alignment"))
204 ,(align-offset bits alignment))
206 (values nil 0 element-type))))
208 (let* ((element-type (alien-array-type-element-type alien-type))
209 (bits (alien-type-bits element-type))
210 (alignment (alien-type-alignment element-type))
211 (dims (alien-array-type-dimensions alien-type)))
212 (unless (= (length indices) (length dims))
213 (give-up-ir1-transform "incorrect number of indices"))
215 (give-up-ir1-transform "Element size is unknown."))
217 (give-up-ir1-transform "Element alignment is unknown."))
219 (values nil 0 element-type)
220 (let* ((arg (gensym))
223 (dolist (dim (cdr dims))
224 (let ((arg (gensym)))
226 (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
227 (values (reverse args)
229 ,(align-offset bits alignment))
232 (abort-ir1-transform "~S not either a pointer or array type."
235 #+nil ;; Shouldn't be necessary.
236 (defoptimizer (deref derive-type) ((alien &rest noise))
237 (declare (ignore noise))
239 (catch 'give-up-ir1-transform
240 (return (make-alien-type-type (find-deref-element-type alien))))
243 (deftransform deref ((alien &rest indices) * * :important t)
244 (multiple-value-bind (indices-args offset-expr element-type)
245 (compute-deref-guts alien indices)
246 `(lambda (alien ,@indices-args)
247 (extract-alien-value (alien-sap alien)
251 #+nil ;; ### Again, the value might be coerced.
252 (defoptimizer (%set-deref derive-type) ((alien value &rest noise))
253 (declare (ignore 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-continuation-type value type)
263 (deftransform %set-deref ((alien value &rest indices) * * :important t)
264 (multiple-value-bind (indices-args offset-expr element-type)
265 (compute-deref-guts alien indices)
266 `(lambda (alien value ,@indices-args)
267 (deposit-alien-value (alien-sap alien)
272 (defoptimizer (%deref-addr derive-type) ((alien &rest noise))
273 (declare (ignore noise))
275 (catch 'give-up-ir1-transform
276 (return (make-alien-type-type
277 (make-alien-pointer-type
278 :to (find-deref-element-type alien)))))
281 (deftransform %deref-addr ((alien &rest indices) * * :important t)
282 (multiple-value-bind (indices-args offset-expr element-type)
283 (compute-deref-guts alien indices)
284 (/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
285 `(lambda (alien ,@indices-args)
286 (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:byte-bits))
287 ',(make-alien-pointer-type :to element-type)))))
289 ;;;; support for aliens on the heap
291 (defun heap-alien-sap-and-type (info)
292 (unless (constant-continuation-p info)
293 (give-up-ir1-transform "info not constant; can't open code"))
294 (let ((info (continuation-value info)))
295 (values (heap-alien-info-sap-form info)
296 (heap-alien-info-type info))))
298 #+nil ; shouldn't be necessary
299 (defoptimizer (%heap-alien derive-type) ((info))
302 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
303 (declare (ignore sap))
304 (return (make-alien-type-type type))))
307 (deftransform %heap-alien ((info) * * :important t)
308 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
309 `(extract-alien-value ,sap 0 ',type)))
311 #+nil ;; ### Again, deposit value might change the type.
312 (defoptimizer (%set-heap-alien derive-type) ((info value))
314 (catch 'give-up-ir1-transform
315 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
316 (declare (ignore sap))
317 (let ((type (make-alien-type-type type)))
318 (assert-continuation-type value type)
322 (deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
323 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
324 `(deposit-alien-value ,sap 0 ',type value)))
326 (defoptimizer (%heap-alien-addr derive-type) ((info))
328 (catch 'give-up-ir1-transform
329 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
330 (declare (ignore sap))
331 (return (make-alien-type-type (make-alien-pointer-type :to type)))))
334 (deftransform %heap-alien-addr ((info) * * :important t)
335 (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
336 (/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
337 `(%sap-alien ,sap ',type)))
339 ;;;; support for local (stack or register) aliens
341 (deftransform make-local-alien ((info) * * :important t)
342 (unless (constant-continuation-p info)
343 (abort-ir1-transform "Local alien info isn't constant?"))
344 (let* ((info (continuation-value info))
345 (alien-type (local-alien-info-type info))
346 (bits (alien-type-bits alien-type)))
348 (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
349 (/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
350 (/noshow (local-alien-info-force-to-memory-p info))
351 (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
352 (if (local-alien-info-force-to-memory-p info)
353 #!+x86 `(truly-the system-area-pointer
354 (%primitive alloc-alien-stack-space
355 ,(ceiling (alien-type-bits alien-type)
357 #!-x86 `(truly-the system-area-pointer
358 (%primitive alloc-number-stack-space
359 ,(ceiling (alien-type-bits alien-type)
361 (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
362 (alien-rep-type (specifier-type alien-rep-type-spec)))
363 (cond ((csubtypep (specifier-type 'system-area-pointer)
366 ((ctypep 0 alien-rep-type) 0)
367 ((ctypep 0.0f0 alien-rep-type) 0.0f0)
368 ((ctypep 0.0d0 alien-rep-type) 0.0d0)
371 "Aliens of type ~S cannot be represented immediately."
372 (unparse-alien-type alien-type))))))))
374 (deftransform note-local-alien-type ((info var) * * :important t)
375 ;; FIXME: This test and error occur about a zillion times. They
376 ;; could be factored into a function.
377 (unless (constant-continuation-p info)
378 (abort-ir1-transform "Local alien info isn't constant?"))
379 (let ((info (continuation-value info)))
380 (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info)
381 (/noshow (local-alien-info-force-to-memory-p info))
382 (unless (local-alien-info-force-to-memory-p info)
383 (let ((var-node (continuation-use var)))
384 (/noshow var-node (ref-p var-node))
385 (when (ref-p var-node)
386 (propagate-to-refs (ref-leaf var-node)
388 (compute-alien-rep-type
389 (local-alien-info-type info))))))))
392 (deftransform local-alien ((info var) * * :important t)
393 (unless (constant-continuation-p info)
394 (abort-ir1-transform "Local alien info isn't constant?"))
395 (let* ((info (continuation-value info))
396 (alien-type (local-alien-info-type info)))
397 (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
398 (/noshow (local-alien-info-force-to-memory-p info))
399 (if (local-alien-info-force-to-memory-p info)
400 `(extract-alien-value var 0 ',alien-type)
401 `(naturalize var ',alien-type))))
403 (deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
404 (unless (constant-continuation-p info)
405 (abort-ir1-transform "Local alien info isn't constant?"))
406 (let ((info (continuation-value info)))
407 (local-alien-info-force-to-memory-p info)))
409 (deftransform %set-local-alien ((info var value) * * :important t)
410 (unless (constant-continuation-p info)
411 (abort-ir1-transform "Local alien info isn't constant?"))
412 (let* ((info (continuation-value info))
413 (alien-type (local-alien-info-type info)))
414 (if (local-alien-info-force-to-memory-p info)
415 `(deposit-alien-value var 0 ',alien-type value)
416 '(error "This should be eliminated as dead code."))))
418 (defoptimizer (%local-alien-addr derive-type) ((info var))
419 (if (constant-continuation-p info)
420 (let* ((info (continuation-value info))
421 (alien-type (local-alien-info-type info)))
422 (make-alien-type-type (make-alien-pointer-type :to alien-type)))
425 (deftransform %local-alien-addr ((info var) * * :important t)
426 (unless (constant-continuation-p info)
427 (abort-ir1-transform "Local alien info isn't constant?"))
428 (let* ((info (continuation-value info))
429 (alien-type (local-alien-info-type info)))
430 (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
431 (if (local-alien-info-force-to-memory-p info)
432 `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
433 (error "This shouldn't happen."))))
435 (deftransform dispose-local-alien ((info var) * * :important t)
436 (unless (constant-continuation-p info)
437 (abort-ir1-transform "Local alien info isn't constant?"))
438 (let* ((info (continuation-value info))
439 (alien-type (local-alien-info-type info)))
440 (if (local-alien-info-force-to-memory-p info)
441 #!+x86 `(%primitive dealloc-alien-stack-space
442 ,(ceiling (alien-type-bits alien-type)
444 #!-x86 `(%primitive dealloc-number-stack-space
445 ,(ceiling (alien-type-bits alien-type)
451 (defoptimizer (%cast derive-type) ((alien type))
452 (or (when (constant-continuation-p type)
453 (let ((alien-type (continuation-value type)))
454 (when (alien-type-p alien-type)
455 (make-alien-type-type alien-type))))
458 (deftransform %cast ((alien target-type) * * :important t)
459 (unless (constant-continuation-p target-type)
460 (give-up-ir1-transform
461 "The alien type is not constant, so access cannot be open coded."))
462 (let ((target-type (continuation-value target-type)))
463 (cond ((or (alien-pointer-type-p target-type)
464 (alien-array-type-p target-type)
465 (alien-function-type-p target-type))
466 `(naturalize (alien-sap alien) ',target-type))
468 (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
470 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
472 (deftransform alien-sap ((alien) * * :important t)
473 (let ((alien-node (continuation-use alien)))
476 (extract-function-args alien '%sap-alien 2)
478 (declare (ignore type))
481 (give-up-ir1-transform)))))
483 (defoptimizer (%sap-alien derive-type) ((sap type))
484 (declare (ignore sap))
485 (if (constant-continuation-p type)
486 (make-alien-type-type (continuation-value type))
489 (deftransform %sap-alien ((sap type) * * :important t)
490 (give-up-ir1-transform
491 "could not optimize away %SAP-ALIEN: forced to do runtime ~@
492 allocation of alien-value structure"))
494 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
496 (flet ((%computed-lambda (compute-lambda type)
497 (declare (type function compute-lambda))
498 (unless (constant-continuation-p type)
499 (give-up-ir1-transform
500 "The type is not constant at compile time; can't open code."))
502 (let ((result (funcall compute-lambda (continuation-value type))))
503 (/noshow "in %COMPUTED-LAMBDA" (continuation-value type) result)
506 (compiler-error "~A" condition)))))
507 (deftransform naturalize ((object type) * * :important t)
508 (%computed-lambda #'compute-naturalize-lambda type))
509 (deftransform deport ((alien type) * * :important t)
510 (%computed-lambda #'compute-deport-lambda type))
511 (deftransform extract-alien-value ((sap offset type) * * :important t)
512 (%computed-lambda #'compute-extract-lambda type))
513 (deftransform deposit-alien-value ((sap offset type value) * * :important t)
514 (%computed-lambda #'compute-deposit-lambda type)))
516 ;;;; a hack to clean up divisions
518 (defun count-low-order-zeros (thing)
521 (if (constant-continuation-p thing)
522 (count-low-order-zeros (continuation-value thing))
523 (count-low-order-zeros (continuation-use thing))))
525 (case (continuation-function-name (combination-fun thing))
527 (let ((min most-positive-fixnum)
528 (itype (specifier-type 'integer)))
529 (dolist (arg (combination-args thing) min)
530 (if (csubtypep (continuation-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 (continuation-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-continuation-p amount)
545 (max (+ (count-low-order-zeros (first args))
546 (continuation-value amount))
555 (do ((result 0 (1+ result))
556 (num thing (ash num -1)))
557 ((logbitp 0 num) result))))
561 (deftransform / ((numerator denominator) (integer integer))
562 (unless (constant-continuation-p denominator)
563 (give-up-ir1-transform))
564 (let* ((denominator (continuation-value denominator))
565 (bits (1- (integer-length denominator))))
566 (unless (= (ash 1 bits) denominator)
567 (give-up-ir1-transform))
568 (let ((alignment (count-low-order-zeros numerator)))
569 (unless (>= alignment bits)
570 (give-up-ir1-transform))
571 `(ash numerator ,(- bits)))))
573 (deftransform ash ((value amount))
574 (let ((value-node (continuation-use value)))
575 (unless (and (combination-p value-node)
576 (eq (continuation-function-name (combination-fun value-node))
578 (give-up-ir1-transform))
579 (let ((inside-args (combination-args value-node)))
580 (unless (= (length inside-args) 2)
581 (give-up-ir1-transform))
582 (let ((inside-amount (second inside-args)))
583 (unless (and (constant-continuation-p inside-amount)
584 (not (minusp (continuation-value inside-amount))))
585 (give-up-ir1-transform)))))
586 (extract-function-args value 'ash 2)
587 '(lambda (value amount1 amount2)
588 (ash value (+ amount1 amount2))))
590 ;;;; ALIEN-FUNCALL support
592 (deftransform alien-funcall ((function &rest args)
593 ((alien (* t)) &rest *) *
595 (let ((names (make-gensym-list (length args))))
596 (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
597 `(lambda (function ,@names)
598 (alien-funcall (deref function) ,@names))))
600 (deftransform alien-funcall ((function &rest args) * * :important t)
601 (let ((type (continuation-type function)))
602 (unless (alien-type-type-p type)
603 (give-up-ir1-transform "can't tell function type at compile time"))
604 (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
605 (let ((alien-type (alien-type-type-alien-type type)))
606 (unless (alien-function-type-p alien-type)
607 (give-up-ir1-transform))
608 (let ((arg-types (alien-function-type-arg-types alien-type)))
609 (unless (= (length args) (length arg-types))
611 "wrong number of arguments; expected ~D, got ~D"
614 (collect ((params) (deports))
615 (dolist (arg-type arg-types)
616 (let ((param (gensym)))
618 (deports `(deport ,param ',arg-type))))
619 (let ((return-type (alien-function-type-result-type alien-type))
620 (body `(%alien-funcall (deport function ',alien-type)
623 (if (alien-values-type-p return-type)
624 (collect ((temps) (results))
625 (dolist (type (alien-values-type-values return-type))
626 (let ((temp (gensym)))
628 (results `(naturalize ,temp ',type))))
630 `(multiple-value-bind ,(temps) ,body
631 (values ,@(results)))))
632 (setf body `(naturalize ,body ',return-type)))
633 (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
634 `(lambda (function ,@(params))
637 (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
638 (declare (ignore function args))
639 (unless (constant-continuation-p type)
640 (error "Something is broken."))
641 (let ((type (continuation-value type)))
642 (unless (alien-function-type-p type)
643 (error "Something is broken."))
645 (compute-alien-rep-type
646 (alien-function-type-result-type type)))))
648 (defoptimizer (%alien-funcall ltn-annotate)
649 ((function type &rest args) node policy)
650 (setf (basic-combination-info node) :funny)
651 (setf (node-tail-p node) nil)
652 (annotate-ordinary-continuation function policy)
654 (annotate-ordinary-continuation arg policy)))
656 (defoptimizer (%alien-funcall ir2-convert)
657 ((function type &rest args) call block)
658 (let ((type (if (constant-continuation-p type)
659 (continuation-value type)
660 (error "Something is broken.")))
661 (cont (node-cont call))
663 (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
664 (make-call-out-tns type)
665 (vop alloc-number-stack-space call block stack-frame-size nsp)
667 (let* ((arg (pop args))
670 #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
672 (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
674 (assert (= (length move-arg-vops) 1) ()
675 "no unique move-arg-vop for moves in SC ~S"
677 #!+x86 (emit-move-arg-template call
679 (first move-arg-vops)
680 (continuation-tn call block arg)
686 (continuation-tn call block arg)
688 (emit-move-arg-template call
690 (first move-arg-vops)
695 (unless (listp result-tns)
696 (setf result-tns (list result-tns)))
697 (vop* call-out call block
698 ((continuation-tn call block function)
699 (reference-tn-list arg-tns nil))
700 ((reference-tn-list result-tns t)))
701 (vop dealloc-number-stack-space call block stack-frame-size)
702 (move-continuation-result call block result-tns cont))))