src/compiler/fun-info-funs.lisp

   1 ;;;; functions which have a build order dependency on FUN-INFO
   2 ;;;; (because ANSI allows xc host structure slot setters to be
   3 ;;;; implemented as SETF expanders instead of SETF functions, so we
   4 ;;;; can't safely forward-reference them) and so have to be defined
   5 ;;;; physically late instead of in a more logical place
   6
   7 (in-package "SB!C")
   8
   9 (defun %def-reffer (name offset lowtag)
  10   (let ((fun-info (fun-info-or-lose name)))
  11     (setf (fun-info-ir2-convert fun-info)
  12           (lambda (node block)
  13             (ir2-convert-reffer node block name offset lowtag))))
  14   name)
  15
  16 (defun %def-setter (name offset lowtag)
  17   (let ((fun-info (fun-info-or-lose name)))
  18     (setf (fun-info-ir2-convert fun-info)
  19           (if (listp name)
  20               (lambda (node block)
  21                 (ir2-convert-setfer node block name offset lowtag))
  22               (lambda (node block)
  23                 (ir2-convert-setter node block name offset lowtag)))))
  24   name)
  25
  26 (defun %def-alloc (name words allocation-style header lowtag inits)
  27   (let ((info (fun-info-or-lose name)))
  28     (setf (fun-info-ir2-convert info)
  29           (ecase allocation-style
  30             (:var-alloc
  31              (lambda (node block)
  32                 (ir2-convert-variable-allocation node block name words header
  33                                                  lowtag inits)))
  34             (:fixed-alloc
  35              (lambda (node block)
  36                (ir2-convert-fixed-allocation node block name words header
  37                                              lowtag inits)))
  38             (:structure-alloc
  39              (lambda (node block)
  40                (ir2-convert-structure-allocation node block name words header
  41                                                  lowtag inits))))))
  42   name)
  43
  44 (defun %def-casser (name offset lowtag)
  45   (let ((fun-info (fun-info-or-lose name)))
  46     (setf (fun-info-ir2-convert fun-info)
  47           (lambda (node block)
  48             (ir2-convert-casser node block name offset lowtag)))))