0.pre7.20:
[sbcl.git] / 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                 (aver 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   (aver (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                     (aver (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           (aver (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))))