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