src/compiler/generic/vm-ir2tran.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!C")
  11
  12 (file-comment
  13   "$Header$")
  14
  15 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
  16   (let* ((cont (node-cont node))
  17          (locs (continuation-result-tns cont
  18                                         (list *backend-t-primitive-type*)))
  19          (res (first locs)))
  20     (vop slot node block (continuation-tn node block object)
  21          name offset lowtag res)
  22     (move-continuation-result node block locs cont)))
  23
  24 #!+gengc
  25 (defun needs-remembering (cont)
  26   (if (csubtypep (continuation-type cont)
  27                  (load-time-value (specifier-type '(or fixnum character
  28                                                        (member t nil)))))
  29       nil
  30       t))
  31
  32 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
  33   (let ((value-tn (continuation-tn node block value)))
  34     (vop set-slot node block (continuation-tn node block object) value-tn
  35          name offset lowtag #!+gengc (needs-remembering value))
  36     (move-continuation-result node block (list value-tn) (node-cont node))))
  37
  38 (defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
  39   (let ((value-tn (continuation-tn node block value)))
  40     (vop set-slot node block (continuation-tn node block object) value-tn
  41          name offset lowtag #!+gengc (needs-remembering value))
  42     (move-continuation-result node block (list value-tn) (node-cont node))))
  43
  44 (defun do-inits (node block name result lowtag inits args)
  45   (let ((unbound-marker-tn nil))
  46     (dolist (init inits)
  47       (let ((kind (car init))
  48             (slot (cdr init)))
  49         (vop set-slot node block result
  50              (ecase kind
  51                (:arg
  52                 (assert args)
  53                 (continuation-tn node block (pop args)))
  54                (:unbound
  55                 (or unbound-marker-tn
  56                     (setf unbound-marker-tn
  57                           (let ((tn (make-restricted-tn
  58                                      nil
  59                                      (sc-number-or-lose 'sb!vm::any-reg))))
  60                             (vop make-unbound-marker node block tn)
  61                             tn))))
  62                (:null
  63                 (emit-constant nil)))
  64              name slot lowtag #!+gengc nil))))
  65   (assert (null args)))
  66
  67 (defun do-fixed-alloc (node block name words type lowtag result)
  68   #!-gengc
  69   (vop fixed-alloc node block name words type lowtag result)
  70   #!+gengc
  71   (if (>= words sb!vm:large-object-cutoff)
  72       (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1))
  73            (emit-constant lowtag) (emit-constant type) (emit-constant 0) name
  74            result)
  75       (vop fixed-alloc node block name words type lowtag result)))
  76
  77 (defoptimizer ir2-convert-fixed-allocation
  78               ((&rest args) node block name words type lowtag inits)
  79   (let* ((cont (node-cont node))
  80          (locs (continuation-result-tns cont
  81                                         (list *backend-t-primitive-type*)))
  82          (result (first locs)))
  83     (do-fixed-alloc node block name words type lowtag result)
  84     (do-inits node block name result lowtag inits args)
  85     (move-continuation-result node block locs cont)))
  86
  87 (defoptimizer ir2-convert-variable-allocation
  88               ((extra &rest args) node block name words type lowtag inits)
  89   (let* ((cont (node-cont node))
  90          (locs (continuation-result-tns cont
  91                                         (list *backend-t-primitive-type*)))
  92          (result (first locs)))
  93     (if (constant-continuation-p extra)
  94         (let ((words (+ (continuation-value extra) words)))
  95           (do-fixed-alloc node block name words type lowtag result))
  96         (vop var-alloc node block (continuation-tn node block extra) name words
  97              type lowtag result))
  98     (do-inits node block name result lowtag inits args)
  99     (move-continuation-result node block locs cont)))
 100
 101
 102 \f
 103 ;;;; other allocation support
 104
 105 #!+gengc
 106 (defoptimizer (make-array-header ir2-convert) ((type rank) node block)
 107   (let* ((cont (node-cont node))
 108          (locs (continuation-result-tns cont
 109                                         (list *backend-t-primitive-type*)))
 110          (result (first locs)))
 111     (if (and (constant-continuation-p type)
 112              (constant-continuation-p rank))
 113         (do-fixed-alloc node block 'make-array-header
 114                         (+ (continuation-value rank)
 115                            sb!vm:array-dimensions-offset)
 116                         (continuation-value type)
 117                         sb!vm:other-pointer-type result)
 118         (vop make-array-header node block (continuation-tn node block type)
 119              (continuation-tn node block rank) result))
 120     (move-continuation-result node block locs cont)))
 121 \f
 122 ;;;; replacements for stuff in ir2tran to make gengc work
 123
 124 #!+gengc
 125 (defun ir2-convert-closure (node block leaf res)
 126   (declare (type ref node) (type ir2-block block)
 127            (type functional leaf) (type tn res))
 128   (unless (leaf-info leaf)
 129     (setf (leaf-info leaf) (make-entry-info)))
 130   (let ((entry (make-load-time-constant-tn :entry leaf))
 131         (closure (etypecase leaf
 132                    (clambda
 133                     (environment-closure (get-lambda-environment leaf)))
 134                    (functional
 135                     (assert (eq (functional-kind leaf) :top-level-xep))
 136                     nil))))
 137     (if closure
 138         (let ((this-env (node-environment node)))
 139           #!+gengc (let ((temp (make-normal-tn *backend-t-primitive-type*)))
 140                      (do-fixed-alloc node block 'make-closure
 141                                      (+ (length closure)
 142                                         sb!vm:closure-info-offset)
 143                                      sb!vm:closure-header-type
 144                                      sb!vm:function-pointer-type
 145                                      res)
 146                      (emit-move node block entry temp)
 147                      (vop %set-function-self node block temp res temp))
 148           ;; KLUDGE: #!-GENGC nested inside #!+GENGC doesn't make much sense;
 149           ;; it's just a literal translation of the CMU CL distinction between
 150           ;; host and backend. If GENGC code is ever revived, this should be
 151           ;; cleaned up.
 152           #!-gengc (vop make-closure node block entry (length closure) res)
 153           (loop for what in closure and n from 0 do
 154             (unless (and (lambda-var-p what)
 155                          (null (leaf-refs what)))
 156               (vop closure-init node block
 157                    res
 158                    (find-in-environment what this-env)
 159                    n
 160                    nil))))
 161         (emit-move node block entry res)))
 162   (values))
 163
 164 #!+gengc
 165 (defun ir2-convert-set (node block)
 166   (declare (type cset node) (type ir2-block block))
 167   (let* ((cont (node-cont node))
 168          (leaf (set-var node))
 169          (value (set-value node))
 170          (val-tn (continuation-tn node block value))
 171          (locs (if (continuation-info cont)
 172                    (continuation-result-tns
 173                     cont (list (primitive-type (leaf-type leaf))))
 174                    nil)))
 175     (etypecase leaf
 176       (lambda-var
 177        (when (leaf-refs leaf)
 178          (let ((tn (find-in-environment leaf (node-environment node))))
 179            (if (lambda-var-indirect leaf)
 180                (vop value-cell-set node block tn val-tn
 181                     (needs-remembering value))
 182                (emit-move node block val-tn tn)))))
 183       (global-var
 184        (ecase (global-var-kind leaf)
 185          ((:special :global)
 186           (assert (symbolp (leaf-name leaf)))
 187           (vop set node block (emit-constant (leaf-name leaf)) val-tn
 188                (needs-remembering value))))))
 189
 190     (when locs
 191       (emit-move node block val-tn (first locs))
 192       (move-continuation-result node block locs cont)))
 193   (values))
 194
 195 #!+gengc
 196 (defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
 197   (vop value-cell-set node block
 198        (find-in-environment (continuation-value info) (node-environment node))
 199        (emit-constant 0)
 200        nil))
 201
 202 #!+gengc
 203 (defoptimizer (%slot-setter ir2-convert) ((value str) node block)
 204   (let ((val (continuation-tn node block value)))
 205     (vop instance-set node block
 206          (continuation-tn node block str)
 207          val
 208          (dsd-index
 209           (slot-accessor-slot
 210            (ref-leaf
 211             (continuation-use
 212              (combination-fun node)))))
 213          (needs-remembering value))
 214
 215     (move-continuation-result node block (list val) (node-cont node))))