src/compiler/aliencomp.lisp

   1 ;;;; transforms and other stuff used to compile ALIEN operations
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!C")
  13 \f
  14 ;;;; DEFKNOWNs
  15
  16 (defknown %sap-alien (system-area-pointer alien-type) alien-value
  17   (flushable movable))
  18 (defknown alien-sap (alien-value) system-area-pointer
  19   (flushable movable))
  20
  21 (defknown slot (alien-value symbol) t
  22   (flushable recursive))
  23 (defknown %set-slot (alien-value symbol t) t
  24   (recursive))
  25 (defknown %slot-addr (alien-value symbol) (alien (* t))
  26   (flushable movable recursive))
  27
  28 (defknown deref (alien-value &rest index) t
  29   (flushable))
  30 (defknown %set-deref (alien-value t &rest index) t
  31   ())
  32 (defknown %deref-addr (alien-value &rest index) (alien (* t))
  33   (flushable movable))
  34
  35 (defknown %heap-alien (heap-alien-info) t
  36   (flushable))
  37 (defknown %set-heap-alien (heap-alien-info t) t
  38   ())
  39 (defknown %heap-alien-addr (heap-alien-info) (alien (* t))
  40   (flushable movable))
  41
  42 (defknown make-local-alien (local-alien-info) t
  43   ())
  44 (defknown note-local-alien-type (local-alien-info t) null
  45   ())
  46 (defknown local-alien (local-alien-info t) t
  47   (flushable))
  48 (defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
  49   (movable))
  50 (defknown %set-local-alien (local-alien-info t t) t
  51   ())
  52 (defknown %local-alien-addr (local-alien-info t) (alien (* t))
  53   (flushable movable))
  54
  55 (defknown %cast (alien-value alien-type) alien
  56   (flushable movable))
  57
  58 (defknown naturalize (t alien-type) alien
  59   (flushable movable))
  60 (defknown deport (alien alien-type) t
  61   (flushable movable))
  62 (defknown deport-alloc (alien alien-type) t
  63   (flushable movable))
  64 (defknown %alien-value (system-area-pointer unsigned-byte alien-type) t
  65   (flushable))
  66 (defknown (setf %alien-value) (t system-area-pointer unsigned-byte alien-type) t
  67   ())
  68
  69 (defknown alien-funcall (alien-value &rest *) *
  70   (any recursive))
  71 \f
  72 ;;;; cosmetic transforms
  73
  74 (deftransform slot ((object slot)
  75                     ((alien (* t)) symbol))
  76   '(slot (deref object) slot))
  77
  78 (deftransform %set-slot ((object slot value)
  79                          ((alien (* t)) symbol t))
  80   '(%set-slot (deref object) slot value))
  81
  82 (deftransform %slot-addr ((object slot)
  83                           ((alien (* t)) symbol))
  84   '(%slot-addr (deref object) slot))
  85 \f
  86 ;;;; SLOT support
  87
  88 (defun find-slot-offset-and-type (alien slot)
  89   (unless (constant-lvar-p slot)
  90     (give-up-ir1-transform
  91      "The slot is not constant, so access cannot be open coded."))
  92   (let ((type (lvar-type alien)))
  93     (unless (alien-type-type-p type)
  94       (give-up-ir1-transform))
  95     (let ((alien-type (alien-type-type-alien-type type)))
  96       (unless (alien-record-type-p alien-type)
  97         (give-up-ir1-transform))
  98       (let* ((slot-name (lvar-value slot))
  99              (field (find slot-name (alien-record-type-fields alien-type)
 100                           :key #'alien-record-field-name)))
 101         (unless field
 102           (abort-ir1-transform "~S~% doesn't have a slot named ~S"
 103                                type slot-name))
 104         (values (alien-record-field-offset field)
 105                 (alien-record-field-type field))))))
 106
 107 #+nil ;; Shouldn't be necessary.
 108 (defoptimizer (slot derive-type) ((alien slot))
 109   (block nil
 110     (catch 'give-up-ir1-transform
 111       (multiple-value-bind (slot-offset slot-type)
 112           (find-slot-offset-and-type alien slot)
 113         (declare (ignore slot-offset))
 114         (return (make-alien-type-type slot-type))))
 115     *wild-type*))
 116
 117 (deftransform slot ((alien slot) * *)
 118   (multiple-value-bind (slot-offset slot-type)
 119       (find-slot-offset-and-type alien slot)
 120     `(%alien-value (alien-sap alien)
 121                    ,slot-offset
 122                    ',slot-type)))
 123
 124 #+nil ;; ### But what about coercions?
 125 (defoptimizer (%set-slot derive-type) ((alien slot value))
 126   (block nil
 127     (catch 'give-up-ir1-transform
 128       (multiple-value-bind (slot-offset slot-type)
 129           (find-slot-offset-and-type alien slot)
 130         (declare (ignore slot-offset))
 131         (let ((type (make-alien-type-type slot-type)))
 132           (assert-lvar-type value type)
 133           (return type))))
 134     *wild-type*))
 135
 136 (deftransform %set-slot ((alien slot value) * *)
 137   (multiple-value-bind (slot-offset slot-type)
 138       (find-slot-offset-and-type alien slot)
 139     `(setf (%alien-value (alien-sap alien)
 140                          ,slot-offset
 141                          ',slot-type)
 142            value)))
 143
 144 (defoptimizer (%slot-addr derive-type) ((alien slot))
 145   (block nil
 146     (catch 'give-up-ir1-transform
 147       (multiple-value-bind (slot-offset slot-type)
 148           (find-slot-offset-and-type alien slot)
 149         (declare (ignore slot-offset))
 150         (return (make-alien-type-type
 151                  (make-alien-pointer-type :to slot-type)))))
 152     *wild-type*))
 153
 154 (deftransform %slot-addr ((alien slot) * *)
 155   (multiple-value-bind (slot-offset slot-type)
 156       (find-slot-offset-and-type alien slot)
 157     (/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
 158     `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:n-byte-bits))
 159                  ',(make-alien-pointer-type :to slot-type))))
 160 \f
 161 ;;;; DEREF support
 162
 163 (defun find-deref-alien-type (alien)
 164   (let ((alien-type (lvar-type alien)))
 165     (unless (alien-type-type-p alien-type)
 166       (give-up-ir1-transform))
 167     (let ((alien-type (alien-type-type-alien-type alien-type)))
 168       (if (alien-type-p alien-type)
 169           alien-type
 170           (give-up-ir1-transform)))))
 171
 172 (defun find-deref-element-type (alien)
 173   (let ((alien-type (find-deref-alien-type alien)))
 174     (typecase alien-type
 175       (alien-pointer-type
 176        (alien-pointer-type-to alien-type))
 177       (alien-array-type
 178        (alien-array-type-element-type alien-type))
 179       (t
 180        (give-up-ir1-transform)))))
 181
 182 (defun compute-deref-guts (alien indices)
 183   (let ((alien-type (find-deref-alien-type alien)))
 184     (typecase alien-type
 185       (alien-pointer-type
 186        (when (cdr indices)
 187          (abort-ir1-transform "too many indices for pointer deref: ~W"
 188                               (length indices)))
 189        (let ((element-type (alien-pointer-type-to alien-type)))
 190          (unless element-type
 191            (give-up-ir1-transform "unable to open code deref of wild pointer type"))
 192          (if indices
 193              (let ((bits (alien-type-bits element-type))
 194                    (alignment (alien-type-alignment element-type)))
 195                (unless bits
 196                  (abort-ir1-transform "unknown element size"))
 197                (unless alignment
 198                  (abort-ir1-transform "unknown element alignment"))
 199                (values '(offset)
 200                        `(* offset
 201                            ,(align-offset bits alignment))
 202                        element-type))
 203              (values nil 0 element-type))))
 204       (alien-array-type
 205        (let* ((element-type (alien-array-type-element-type alien-type))
 206               (bits (alien-type-bits element-type))
 207               (alignment (alien-type-alignment element-type))
 208               (dims (alien-array-type-dimensions alien-type)))
 209          (unless (= (length indices) (length dims))
 210            (give-up-ir1-transform "incorrect number of indices"))
 211          (unless bits
 212            (give-up-ir1-transform "Element size is unknown."))
 213          (unless alignment
 214            (give-up-ir1-transform "Element alignment is unknown."))
 215          (if (null dims)
 216              (values nil 0 element-type)
 217              (let* ((arg (gensym))
 218                     (args (list arg))
 219                     (offsetexpr arg))
 220                (dolist (dim (cdr dims))
 221                  (let ((arg (gensym)))
 222                    (push arg args)
 223                    (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
 224                (values (reverse args)
 225                        `(* ,offsetexpr
 226                            ,(align-offset bits alignment))
 227                        element-type)))))
 228       (t
 229        (abort-ir1-transform "~S not either a pointer or array type."
 230                             alien-type)))))
 231
 232 #+nil ;; Shouldn't be necessary.
 233 (defoptimizer (deref derive-type) ((alien &rest noise))
 234   (declare (ignore noise))
 235   (block nil
 236     (catch 'give-up-ir1-transform
 237       (return (make-alien-type-type (find-deref-element-type alien))))
 238     *wild-type*))
 239
 240 (deftransform deref ((alien &rest indices) * *)
 241   (multiple-value-bind (indices-args offset-expr element-type)
 242       (compute-deref-guts alien indices)
 243     `(lambda (alien ,@indices-args)
 244        (%alien-value (alien-sap alien)
 245                      ,offset-expr
 246                      ',element-type))))
 247
 248 #+nil ;; ### Again, the value might be coerced.
 249 (defoptimizer (%set-deref derive-type) ((alien value &rest noise))
 250   (declare (ignore noise))
 251   (block nil
 252     (catch 'give-up-ir1-transform
 253       (let ((type (make-alien-type-type
 254                    (make-alien-pointer-type
 255                     :to (find-deref-element-type alien)))))
 256         (assert-lvar-type value type)
 257         (return type)))
 258     *wild-type*))
 259
 260 (deftransform %set-deref ((alien value &rest indices) * *)
 261   (multiple-value-bind (indices-args offset-expr element-type)
 262       (compute-deref-guts alien indices)
 263     `(lambda (alien value ,@indices-args)
 264        (setf (%alien-value (alien-sap alien)
 265                            ,offset-expr
 266                            ',element-type)
 267              value))))
 268
 269 (defoptimizer (%deref-addr derive-type) ((alien &rest noise))
 270   (declare (ignore noise))
 271   (block nil
 272     (catch 'give-up-ir1-transform
 273       (return (make-alien-type-type
 274                (make-alien-pointer-type
 275                 :to (find-deref-element-type alien)))))
 276     *wild-type*))
 277
 278 (deftransform %deref-addr ((alien &rest indices) * *)
 279   (multiple-value-bind (indices-args offset-expr element-type)
 280       (compute-deref-guts alien indices)
 281     (/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
 282     `(lambda (alien ,@indices-args)
 283        (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:n-byte-bits))
 284                    ',(make-alien-pointer-type :to element-type)))))
 285 \f
 286 ;;;; support for aliens on the heap
 287
 288 (defun heap-alien-sap-and-type (info)
 289   (unless (constant-lvar-p info)
 290     (give-up-ir1-transform "info not constant; can't open code"))
 291   (let ((info (lvar-value info)))
 292     (values (heap-alien-info-sap-form info)
 293             (heap-alien-info-type info))))
 294
 295 #+nil ; shouldn't be necessary
 296 (defoptimizer (%heap-alien derive-type) ((info))
 297   (block nil
 298     (catch 'give-up
 299       (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
 300         (declare (ignore sap))
 301         (return (make-alien-type-type type))))
 302     *wild-type*))
 303
 304 (deftransform %heap-alien ((info) ((constant-arg heap-alien-info)) *)
 305   (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
 306     `(%alien-value ,sap 0 ',type)))
 307
 308 #+nil ;; ### Again, deposit value might change the type.
 309 (defoptimizer (%set-heap-alien derive-type) ((info value))
 310   (block nil
 311     (catch 'give-up-ir1-transform
 312       (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
 313         (declare (ignore sap))
 314         (let ((type (make-alien-type-type type)))
 315           (assert-lvar-type value type)
 316           (return type))))
 317     *wild-type*))
 318
 319 (deftransform %set-heap-alien ((info value) (heap-alien-info *) *)
 320   (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
 321     `(setf (%alien-value ,sap 0 ',type) value)))
 322
 323 (defoptimizer (%heap-alien-addr derive-type) ((info))
 324   (block nil
 325     (catch 'give-up-ir1-transform
 326       (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
 327         (declare (ignore sap))
 328         (return (make-alien-type-type (make-alien-pointer-type :to type)))))
 329     *wild-type*))
 330
 331 (deftransform %heap-alien-addr ((info) * *)
 332   (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
 333     (/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
 334     `(%sap-alien ,sap ',(make-alien-pointer-type :to type))))
 335
 336 \f
 337 ;;;; support for local (stack or register) aliens
 338
 339 (defun alien-info-constant-or-abort (info)
 340   (unless (constant-lvar-p info)
 341     (abort-ir1-transform "Local alien info isn't constant?")))
 342
 343 (deftransform make-local-alien ((info) * *)
 344   (alien-info-constant-or-abort info)
 345   (let* ((info (lvar-value info))
 346          (alien-type (local-alien-info-type info))
 347          (bits (alien-type-bits alien-type)))
 348     (unless bits
 349       (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
 350     (/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
 351     (/noshow (local-alien-info-force-to-memory-p info))
 352     (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
 353     (if (local-alien-info-force-to-memory-p info)
 354         #!+(or x86 x86-64)
 355         `(%primitive alloc-alien-stack-space
 356                      ,(ceiling (alien-type-bits alien-type)
 357                                sb!vm:n-byte-bits))
 358         #!-(or x86 x86-64)
 359         `(%primitive alloc-number-stack-space
 360                      ,(ceiling (alien-type-bits alien-type)
 361                                sb!vm:n-byte-bits))
 362         (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
 363                (alien-rep-type (specifier-type alien-rep-type-spec)))
 364           (cond ((csubtypep (specifier-type 'system-area-pointer)
 365                             alien-rep-type)
 366                  '(int-sap 0))
 367                 ((ctypep 0 alien-rep-type) 0)
 368                 ((ctypep 0.0f0 alien-rep-type) 0.0f0)
 369                 ((ctypep 0.0d0 alien-rep-type) 0.0d0)
 370                 (t
 371                  (compiler-error
 372                   "Aliens of type ~S cannot be represented immediately."
 373                   (unparse-alien-type alien-type))))))))
 374
 375 (deftransform note-local-alien-type ((info var) * *)
 376   (alien-info-constant-or-abort info)
 377   (let ((info (lvar-value info)))
 378     (unless (local-alien-info-force-to-memory-p info)
 379       (let ((var-node (lvar-uses var)))
 380         (when (and (ref-p var-node)
 381                    (constant-reference-p var-node))
 382           (propagate-to-refs (ref-leaf var-node)
 383                              (specifier-type
 384                               (compute-alien-rep-type
 385                                (local-alien-info-type info))))))))
 386   nil)
 387
 388 (deftransform local-alien ((info var) * *)
 389   (alien-info-constant-or-abort info)
 390   (let* ((info (lvar-value info))
 391          (alien-type (local-alien-info-type info)))
 392     (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
 393     (/noshow (local-alien-info-force-to-memory-p info))
 394     (if (local-alien-info-force-to-memory-p info)
 395         `(%alien-value var 0 ',alien-type)
 396         `(naturalize var ',alien-type))))
 397
 398 (deftransform %local-alien-forced-to-memory-p ((info) * *)
 399   (alien-info-constant-or-abort info)
 400   (let ((info (lvar-value info)))
 401     (local-alien-info-force-to-memory-p info)))
 402
 403 (deftransform %set-local-alien ((info var value) * *)
 404   (alien-info-constant-or-abort info)
 405   (let* ((info (lvar-value info))
 406          (alien-type (local-alien-info-type info)))
 407     (if (local-alien-info-force-to-memory-p info)
 408         `(setf (%alien-value var 0 ',alien-type) value)
 409         '(error "This should be eliminated as dead code."))))
 410
 411 (defoptimizer (%local-alien-addr derive-type) ((info var))
 412   (declare (ignore var))
 413   (if (constant-lvar-p info)
 414       (let* ((info (lvar-value info))
 415              (alien-type (local-alien-info-type info)))
 416         (make-alien-type-type (make-alien-pointer-type :to alien-type)))
 417       *wild-type*))
 418
 419 (deftransform %local-alien-addr ((info var) * *)
 420   (alien-info-constant-or-abort info)
 421   (let* ((info (lvar-value info))
 422          (alien-type (local-alien-info-type info)))
 423     (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
 424     (if (local-alien-info-force-to-memory-p info)
 425         `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
 426         (error "This shouldn't happen."))))
 427 \f
 428 ;;;; %CAST
 429
 430 (defoptimizer (%cast derive-type) ((alien type))
 431   (declare (ignore alien))
 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))))
 436       *wild-type*))
 437
 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))
 447           (t
 448            (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
 449 \f
 450 ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
 451
 452 (deftransform alien-sap ((alien) * *)
 453   (let ((alien-node (lvar-uses alien)))
 454     (typecase alien-node
 455       (combination
 456        (splice-fun-args alien '%sap-alien 2)
 457        '(lambda (sap type)
 458           (declare (ignore type))
 459           sap))
 460       (t
 461        (give-up-ir1-transform)))))
 462
 463 (defoptimizer (%sap-alien derive-type) ((sap type))
 464   (declare (ignore sap))
 465   (if (constant-lvar-p type)
 466       (make-alien-type-type (lvar-value type))
 467       *wild-type*))
 468
 469 (deftransform %sap-alien ((sap type) * *)
 470   (give-up-ir1-transform
 471    ;; FIXME: The hardcoded newline here causes more-than-usually
 472    ;; screwed-up formatting of the optimization note output.
 473    "could not optimize away %SAP-ALIEN: forced to do runtime ~@
 474     allocation of alien-value structure"))
 475 \f
 476 ;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
 477
 478 (flet ((%computed-lambda (compute-lambda type)
 479          (declare (type function compute-lambda))
 480          (unless (constant-lvar-p type)
 481            (give-up-ir1-transform
 482             "The type is not constant at compile time; can't open code."))
 483          (handler-case
 484              (let ((result (funcall compute-lambda (lvar-value type))))
 485                (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result)
 486                result)
 487            (error (condition)
 488                   (compiler-error "~A" condition)))))
 489   (deftransform naturalize ((object type) * *)
 490     (%computed-lambda #'compute-naturalize-lambda type))
 491   (deftransform deport ((alien type) * *)
 492     (%computed-lambda #'compute-deport-lambda type))
 493   (deftransform deport-alloc ((alien type) * *)
 494     (%computed-lambda #'compute-deport-alloc-lambda type))
 495   (deftransform %alien-value ((sap offset type) * *)
 496     (%computed-lambda #'compute-extract-lambda type))
 497   (deftransform (setf %alien-value) ((value sap offset type) * *)
 498     (%computed-lambda #'compute-deposit-lambda type)))
 499 \f
 500 ;;;; a hack to clean up divisions
 501
 502 (defun count-low-order-zeros (thing)
 503   (typecase thing
 504     (lvar
 505      (if (constant-lvar-p thing)
 506          (count-low-order-zeros (lvar-value thing))
 507          (count-low-order-zeros (lvar-uses thing))))
 508     (combination
 509      (case (let ((name (lvar-fun-name (combination-fun thing))))
 510              (or (modular-version-info name :untagged nil) name))
 511        ((+ -)
 512         (let ((min most-positive-fixnum)
 513               (itype (specifier-type 'integer)))
 514           (dolist (arg (combination-args thing) min)
 515             (if (csubtypep (lvar-type arg) itype)
 516                 (setf min (min min (count-low-order-zeros arg)))
 517                 (return 0)))))
 518        (*
 519         (let ((result 0)
 520               (itype (specifier-type 'integer)))
 521           (dolist (arg (combination-args thing) result)
 522             (if (csubtypep (lvar-type arg) itype)
 523                 (setf result (+ result (count-low-order-zeros arg)))
 524                 (return 0)))))
 525        (ash
 526         (let ((args (combination-args thing)))
 527           (if (= (length args) 2)
 528               (let ((amount (second args)))
 529                 (if (constant-lvar-p amount)
 530                     (max (+ (count-low-order-zeros (first args))
 531                             (lvar-value amount))
 532                          0)
 533                     0))
 534               0)))
 535        (t
 536         0)))
 537     (integer
 538      (if (zerop thing)
 539          most-positive-fixnum
 540          (do ((result 0 (1+ result))
 541               (num thing (ash num -1)))
 542              ((logbitp 0 num) result))))
 543     (cast
 544      (count-low-order-zeros (cast-value thing)))
 545     (t
 546      0)))
 547
 548 (deftransform / ((numerator denominator) (integer integer))
 549   "convert x/2^k to shift"
 550   (unless (constant-lvar-p denominator)
 551     (give-up-ir1-transform))
 552   (let* ((denominator (lvar-value denominator))
 553          (bits (1- (integer-length denominator))))
 554     (unless (and (> denominator 0) (= (ash 1 bits) denominator))
 555       (give-up-ir1-transform))
 556     (let ((alignment (count-low-order-zeros numerator)))
 557       (unless (>= alignment bits)
 558         (give-up-ir1-transform))
 559       `(ash numerator ,(- bits)))))
 560
 561 (deftransform ash ((value amount))
 562   (let ((value-node (lvar-uses value)))
 563     (unless (combination-p value-node)
 564       (give-up-ir1-transform))
 565     (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
 566       (multiple-value-bind (prototype width)
 567           (modular-version-info inside-fun-name :untagged nil)
 568         (unless (eq (or prototype inside-fun-name) 'ash)
 569           (give-up-ir1-transform))
 570         (when (and width (not (constant-lvar-p amount)))
 571           (give-up-ir1-transform))
 572         (let ((inside-args (combination-args value-node)))
 573           (unless (= (length inside-args) 2)
 574             (give-up-ir1-transform))
 575           (let ((inside-amount (second inside-args)))
 576             (unless (and (constant-lvar-p inside-amount)
 577                          (not (minusp (lvar-value inside-amount))))
 578               (give-up-ir1-transform)))
 579           (splice-fun-args value inside-fun-name 2)
 580           (if width
 581               `(lambda (value amount1 amount2)
 582                  (logand (ash value (+ amount1 amount2))
 583                          ,(1- (ash 1 (+ width (lvar-value amount))))))
 584               `(lambda (value amount1 amount2)
 585                  (ash value (+ amount1 amount2)))))))))
 586 \f
 587 ;;;; ALIEN-FUNCALL support
 588
 589 (deftransform alien-funcall ((function &rest args)
 590                              ((alien (* t)) &rest *) *)
 591   (let ((names (make-gensym-list (length args))))
 592     (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
 593     `(lambda (function ,@names)
 594        (alien-funcall (deref function) ,@names))))
 595
 596 #-sb-xc-host
 597 (defun find-saved-fp-and-pc (fp)
 598   (dolist (x *saved-fp-and-pcs*)
 599     (declare (type (simple-array word (2)) x))
 600     (when (#!+stack-grows-downward-not-upward
 601            sap>
 602            #!-stack-grows-downward-not-upward
 603            sap<
 604            (int-sap (aref x 0)) fp)
 605       (return (values (int-sap (aref x 0)) (int-sap (aref x 1)))))))
 606
 607 (deftransform alien-funcall ((function &rest args) * * :node node)
 608   (let ((type (lvar-type function)))
 609     (unless (alien-type-type-p type)
 610       (give-up-ir1-transform "can't tell function type at compile time"))
 611     (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
 612     (let ((alien-type (alien-type-type-alien-type type)))
 613       (unless (alien-fun-type-p alien-type)
 614         (give-up-ir1-transform))
 615       (let ((arg-types (alien-fun-type-arg-types alien-type)))
 616         (unless (= (length args) (length arg-types))
 617           (abort-ir1-transform
 618            "wrong number of arguments; expected ~W, got ~W"
 619            (length arg-types)
 620            (length args)))
 621         (collect ((params) (deports))
 622           (dolist (arg-type arg-types)
 623             (let ((param (gensym)))
 624               (params param)
 625               (deports `(deport ,param ',arg-type))))
 626           ;; Build BODY from the inside out.
 627           (let ((return-type (alien-fun-type-result-type alien-type))
 628                 ;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
 629                 ;; to them) and do the call.
 630                 (body `(%alien-funcall (deport function ',alien-type)
 631                                        ',alien-type
 632                                        ,@(deports))))
 633             ;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
 634             ;; the SAPs are taken for won't be moved by the GC. (If
 635             ;; needed: some alien types won't need it).
 636             (setf body `(maybe-with-pinned-objects ,(params) ,arg-types
 637                           ,body))
 638             ;; Around that handle any memory allocation that's needed.
 639             ;; Mostly the DEPORT-ALLOC alien-type-methods are just an
 640             ;; identity operation, but for example for deporting a
 641             ;; Unicode string we need to convert the string into an
 642             ;; octet array. This step needs to be done before the pinning
 643             ;; to ensure we pin the right objects, so it can't be combined
 644             ;; with the deporting.
 645             ;; -- JES 2006-03-16
 646             (loop for param in (params)
 647                   for arg-type in arg-types
 648                   do (setf body
 649                            `(let ((,param (deport-alloc ,param ',arg-type)))
 650                               ,body)))
 651             (if (alien-values-type-p return-type)
 652                 (collect ((temps) (results))
 653                   (dolist (type (alien-values-type-values return-type))
 654                     (let ((temp (gensym)))
 655                       (temps temp)
 656                       (results `(naturalize ,temp ',type))))
 657                   (setf body
 658                         `(multiple-value-bind ,(temps) ,body
 659                            (values ,@(results)))))
 660                 (setf body `(naturalize ,body ',return-type)))
 661             ;; Remember this frame to make sure that we can get back
 662             ;; to it later regardless of how the foreign stack looks
 663             ;; like.
 664             #!+c-stack-is-control-stack
 665             (when (policy node (= 3 alien-funcall-saves-fp-and-pc))
 666               (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body))))
 667             (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
 668             `(lambda (function ,@(params))
 669                (declare (optimize (let-conversion 3)))
 670                ,body)))))))
 671
 672 (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
 673   (declare (ignore function args))
 674   (unless (constant-lvar-p type)
 675     (error "Something is broken."))
 676   (let ((type (lvar-value type)))
 677     (unless (alien-fun-type-p type)
 678       (error "Something is broken."))
 679     (values-specifier-type
 680      (compute-alien-rep-type
 681       (alien-fun-type-result-type type)
 682       :result))))
 683
 684 (defoptimizer (%alien-funcall ltn-annotate)
 685               ((function type &rest args) node ltn-policy)
 686   (declare (ignore type ltn-policy))
 687   (setf (basic-combination-info node) :funny)
 688   (setf (node-tail-p node) nil)
 689   (annotate-ordinary-lvar function)
 690   (dolist (arg args)
 691     (annotate-ordinary-lvar arg)))
 692
 693 ;;; We support both the stdcall and cdecl calling conventions on win32 by
 694 ;;; resetting ESP after the foreign function returns. This way it works
 695 ;;; correctly whether the party that is supposed to pop arguments from
 696 ;;; the stack is the caller (cdecl) or the callee (stdcall).
 697 (defoptimizer (%alien-funcall ir2-convert)
 698               ((function type &rest args) call block)
 699   (let ((type (if (constant-lvar-p type)
 700                   (lvar-value type)
 701                   (error "Something is broken.")))
 702         (lvar (node-lvar call))
 703         ;; KLUDGE: On ARM systems our register pressure is so high
 704         ;; that if we process register args before stack args we end
 705         ;; up with all of our non-descriptor regs either
 706         ;; component-live (NFP) or wired (everything else) and can't
 707         ;; actually process the stack args.  Processing the arguments
 708         ;; in reverse order here doesn't change the semantics, but we
 709         ;; deal with all of the stack arguments before the wired
 710         ;; register arguments become live.
 711         (args #!-arm args #!+arm (reverse args))
 712         #!+c-stack-is-control-stack
 713         (stack-pointer (make-stack-pointer-tn)))
 714     (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
 715         (make-call-out-tns type)
 716       #!+x86
 717       (vop set-fpu-word-for-c call block)
 718       ;; Save the stack pointer, it will get aligned and subtracting
 719       ;; the size will not restore the original value, and some
 720       ;; things, like SB-C::CALL-VARIABLE, use the stack pointer to
 721       ;; calculate the number of saved values.
 722       ;; See alien.impure.lisp/:stack-misalignment
 723       #!+c-stack-is-control-stack
 724       (vop current-stack-pointer call block stack-pointer)
 725       (vop alloc-number-stack-space call block stack-frame-size nsp)
 726       ;; KLUDGE: This is where the second half of the ARM
 727       ;; register-pressure change lives (see above).
 728       (dolist (tn #!-arm arg-tns #!+arm (reverse arg-tns))
 729         ;; On PPC, TN might be a list. This is used to indicate
 730         ;; something special needs to happen. See below.
 731         ;;
 732         ;; FIXME: We should implement something better than this.
 733         (let* ((first-tn (if (listp tn) (car tn) tn))
 734                (arg (pop args))
 735                (sc (tn-sc first-tn))
 736                (scn (sc-number sc))
 737                (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
 738           (aver arg)
 739           (unless (= (length move-arg-vops) 1)
 740             (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
 741           #!+(or x86 x86-64) (emit-move-arg-template call
 742                                                      block
 743                                                      (first move-arg-vops)
 744                                                      (lvar-tn call block arg)
 745                                                      nsp
 746                                                      first-tn)
 747           #!-(or x86 x86-64)
 748           (cond
 749             #!+arm-softfp
 750             ((and (proper-list-of-length-p tn 3)
 751                   (symbolp (third tn)))
 752              (emit-template call block
 753                             (template-or-lose (third tn))
 754                             (reference-tn (lvar-tn call block arg) nil)
 755                             (reference-tn-list (butlast tn) t)))
 756             (t
 757              (let ((temp-tn (make-representation-tn
 758                              (tn-primitive-type first-tn) scn)))
 759                (emit-move call
 760                           block
 761                           (lvar-tn call block arg)
 762                           temp-tn)
 763                (emit-move-arg-template call
 764                                        block
 765                                        (first move-arg-vops)
 766                                        temp-tn
 767                                        nsp
 768                                        first-tn))))
 769           #!+(and ppc darwin)
 770           (when (listp tn)
 771             ;; This means that we have a float arg that we need to
 772             ;; also copy to some int regs. The list contains the TN
 773             ;; for the float as well as the TNs to use for the int
 774             ;; arg.
 775             (destructuring-bind (float-tn i1-tn &optional i2-tn)
 776                 tn
 777               (if i2-tn
 778                   (vop sb!vm::move-double-to-int-arg call block
 779                        float-tn i1-tn i2-tn)
 780                   (vop sb!vm::move-single-to-int-arg call block
 781                        float-tn i1-tn))))))
 782       (aver (null args))
 783       (let ((result-tns (ensure-list result-tns)))
 784         (vop* call-out call block
 785               ((lvar-tn call block function)
 786                (reference-tn-list (remove-if-not #'tn-p (flatten-list arg-tns)) nil))
 787               ((reference-tn-list (remove-if-not #'tn-p result-tns) t)))
 788         #!-c-stack-is-control-stack
 789         (vop dealloc-number-stack-space call block stack-frame-size)
 790         #!+c-stack-is-control-stack
 791         (vop reset-stack-pointer call block stack-pointer)
 792         #!+x86
 793         (vop set-fpu-word-for-lisp call block)
 794         (cond
 795           #!+arm-softfp
 796           ((and lvar
 797                 (proper-list-of-length-p result-tns 3)
 798                 (symbolp (third result-tns)))
 799            (emit-template call block
 800                           (template-or-lose (third result-tns))
 801                           (reference-tn-list (butlast result-tns) nil)
 802                           (reference-tn (car (ir2-lvar-locs (lvar-info lvar))) t)))
 803           (t
 804            (move-lvar-result call block result-tns lvar)))))))