/[cmucl]/src/compiler/tn.lisp
ViewVC logotype

Diff of /src/compiler/tn.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wlott, Tue Feb 6 11:29:39 1990 UTC revision 1.2 by ram, Mon Apr 16 10:49:32 1990 UTC
# Line 77  Line 77 
77    (declare (type primitive-type type))    (declare (type primitive-type type))
78    (let* ((component (component-info *compile-component*))    (let* ((component (component-info *compile-component*))
79           (res (make-tn (incf (ir2-component-global-tn-counter component))           (res (make-tn (incf (ir2-component-global-tn-counter component))
80                         :normal type nil))                         :normal type nil)))
          (costs (tn-costs res)))  
     (dolist (scn (primitive-type-scs type))  
       (setf (svref costs scn) 0))  
81      (push-in tn-next res (ir2-component-normal-tns component))      (push-in tn-next res (ir2-component-normal-tns component))
82      res))      res))
83    
84    
85  ;;; Make-Environment-TN  --  Interface  ;;; Make-Restricted-TN  --  Interface
86  ;;;  ;;;
87  ;;;    Like Make-Normal-TN, but give it a :Environment kind and note it in the  ;;;    Create a packed TN restricted to the SC with number SCN.
 ;;; specified Environment.  
88  ;;;  ;;;
89  (defun make-environment-tn (type env)  (defun make-restricted-tn (scn)
90    (declare (type primitive-type type) (type environment env))    (declare (type sc-number scn))
91    (let ((res (make-normal-tn type)))    (let* ((component (component-info *compile-component*))
92      (setf (tn-kind res) :environment)           (res (make-tn (incf (ir2-component-global-tn-counter component))
93      (push res (ir2-environment-live-tns (environment-info env)))                         :normal nil (svref *sc-numbers* scn))))
94        (push-in tn-next res (ir2-component-restricted-tns component))
95      res))      res))
96    
97    
98  ;;; Make-Restricted-TN  --  Interface  ;;; MAKE-REPRESENTATION-TN  --  Interface
99  ;;;  ;;;
100  ;;;    Create a packed TN restricted to some subset of the SCs normally allowed  ;;;    Create a normal packed TN with representation indicated by SCN.
 ;;; by Type.  SCs is a list of the legal SC numbers.  
101  ;;;  ;;;
102  (defun make-restricted-tn (type scs)  (defun make-representation-tn (scn)
103    (declare (type primitive-type type) (type list scs))    (declare (type sc-number scn))
104    (let* ((component (component-info *compile-component*))    (let* ((component (component-info *compile-component*))
105           (res (make-tn (incf (ir2-component-global-tn-counter component))           (res (make-tn (incf (ir2-component-global-tn-counter component))
106                         :normal type nil))                         :normal nil (svref *sc-numbers* scn))))
107           (costs (tn-costs res)))      (push-in tn-next res (ir2-component-normal-tns component))
     (dolist (scn scs)  
       (setf (svref costs scn) 0))  
     (push-in tn-next res (ir2-component-restricted-tns component))  
108      res))      res))
109    
110    
# Line 119  Line 112 
112  ;;;  ;;;
113  ;;;    Create a TN wired to a particular location in an SC.  We set the Offset  ;;;    Create a TN wired to a particular location in an SC.  We set the Offset
114  ;;; and FSC to record where it goes, and then put it on the current component's  ;;; and FSC to record where it goes, and then put it on the current component's
115  ;;; Wired-TNs list.  Type is used to determine the move/coerce operations.  ;;; Wired-TNs list.
116  ;;;  ;;;
117  (defun make-wired-tn (type scn offset)  (defun make-wired-tn (scn offset)
118    (declare (type primitive-type type) (type sc-number scn)    (declare (type sc-number scn) (type unsigned-byte offset))
            (type unsigned-byte offset))  
119    (let* ((component (component-info *compile-component*))    (let* ((component (component-info *compile-component*))
120           (res (make-tn (incf (ir2-component-global-tn-counter component))           (res (make-tn (incf (ir2-component-global-tn-counter component))
121                         :normal type (svref *sc-numbers* scn))))                         :normal nil (svref *sc-numbers* scn))))
122      (setf (tn-offset res) offset)      (setf (tn-offset res) offset)
123      (push-in tn-next res (ir2-component-wired-tns component))      (push-in tn-next res (ir2-component-wired-tns component))
124      res))      res))
125    
126    
127  ;;; Make-Wired-Environment-TN  --  Interface  ;;; Environment-Live-TN  --  Interface
128  ;;;  ;;;
129  ;;;    Like Make-Wired-TN, but give it a :Environment kind and note it in the  ;;;    Make TN be live throughout environment.  TN must be referenced only in
130  ;;; specified Environment.  ;;; Env.  Return TN.
131  ;;;  ;;;
132  (defun make-wired-environment-tn (type scn offset env)  (defun environment-live-tn (tn env)
133    (declare (type primitive-type type) (type sc-number scn)    (declare (type tn tn) (type environment env))
134             (type unsigned-byte offset) (type environment env))    (assert (eq (tn-kind tn) :normal))
135    (let ((res (make-wired-tn type scn offset)))    (setf (tn-kind tn) :environment)
136      (setf (tn-kind res) :environment)    (push tn (ir2-environment-live-tns (environment-info env)))
137      (push res (ir2-environment-live-tns (environment-info env)))    tn)
138      res))  
139    
140    ;;; Component-Live-TN  --  Interface
141    ;;;
142    ;;;    Make TN be live throughout the current component.  Return TN.
143    ;;;
144    (defun component-live-tn (tn)
145      (declare (type tn tn))
146      (assert (eq (tn-kind tn) :normal))
147      (setf (tn-kind tn) :component)
148      (push tn (ir2-component-component-tns (component-info *compile-component*)))
149      tn)
150    
151    
152  ;;; Make-Constant-TN  --  Interface  ;;; Make-Constant-TN  --  Interface
# Line 262  Line 265 
265    
266  ;;;; Random utilities:  ;;;; Random utilities:
267    
268    
269    ;;; Emit-Move-Template  --  Internal
270    ;;;
271    ;;;    Emit a move-like template determined at run-time, with X as the argument
272    ;;; and Y as the result.  Useful for move, coerce and type-check templates.  If
273    ;;; supplied, then insert before VOP, otherwise insert at then end of the
274    ;;; block.  Returns the last VOP inserted.
275    ;;;
276    (defun emit-move-template (node block template x y &optional before)
277      (declare (type node node) (type ir2-block block)
278               (type template template) (type tn x y))
279      (let ((arg (reference-tn x nil))
280            (result (reference-tn y t)))
281        (multiple-value-bind
282            (first last)
283            (funcall (template-emit-function template) node block template arg
284                     result)
285          (insert-vop-sequence first last block before)
286          last)))
287    
288    
289    ;;; EMIT-LOAD-TEMPLATE  --  Internal
290    ;;;
291    ;;;    Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
292    ;;;
293    (defun emit-load-template (node block template x y info &optional before)
294      (declare (type node node) (type ir2-block block)
295               (type template template) (type tn x y))
296      (let ((arg (reference-tn x nil))
297            (result (reference-tn y t)))
298        (multiple-value-bind
299            (first last)
300            (funcall (template-emit-function template) node block template arg
301                     result info)
302          (insert-vop-sequence first last block before)
303          last)))
304    
305    
306    ;;; EMIT-MOVE-ARG-TEMPLATE  --  Internal
307    ;;;
308    ;;;    Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
309    ;;;
310    (defun emit-move-arg-template (node block template x f y &optional before)
311      (declare (type node node) (type ir2-block block)
312               (type template template) (type tn x f y))
313      (let ((x-ref (reference-tn x nil))
314            (f-ref (reference-tn f nil))
315            (y-ref (reference-tn y t)))
316        (setf (tn-ref-across x-ref) f-ref)
317        (multiple-value-bind
318            (first last)
319            (funcall (template-emit-function template) node block template x-ref
320                     y-ref)
321          (insert-vop-sequence first last block before)
322          last)))
323    
324    
325    ;;; EMIT-CONTEXT-TEMPLATE  --  Internal
326    ;;;
327    ;;;    Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
328    ;;;
329    (defun emit-context-template (node block template y &optional before)
330      (declare (type node node) (type ir2-block block)
331               (type template template) (type tn y))
332      (let ((y-ref (reference-tn y t)))
333        (multiple-value-bind
334            (first last)
335            (funcall (template-emit-function template) node block template nil
336                     y-ref)
337          (insert-vop-sequence first last block before)
338          last)))
339    
340    
341    ;;; Block-Label  --  Interface
342    ;;;
343    ;;;    Return the label marking the start of Block, assigning one if necessary.
344    ;;;
345    (defun block-label (block)
346      (declare (type cblock block))
347      (let ((2block (block-info block)))
348        (or (ir2-block-%label 2block)
349            (setf (ir2-block-%label 2block) (gen-label)))))
350    
351    
352    ;;; Drop-Thru-P  --  Interface
353    ;;;
354    ;;;    Return true if Block is emitted immediately after the block ended by
355    ;;; Node.
356    ;;;
357    (defun drop-thru-p (node block)
358      (declare (type node node) (type cblock block))
359      (let ((next-block (ir2-block-next (block-info (node-block node)))))
360        (assert (eq node (block-last (node-block node))))
361        (eq next-block (block-info block))))
362    
363    
364    ;;; Insert-VOP-Sequence  --  Interface
365    ;;;
366    ;;;    Link a list of VOPs from First to Last into Block, Before the specified
367    ;;; VOP.  If Before is NIL, insert at the end.
368    ;;;
369    (defun insert-vop-sequence (first last block before)
370      (declare (type vop first last) (type ir2-block block)
371               (type (or vop null) before))
372      (if before
373          (let ((prev (vop-prev before)))
374            (setf (vop-prev first) prev)
375            (if prev
376                (setf (vop-next prev) first)
377                (setf (ir2-block-start-vop block) first))
378            (setf (vop-next last) before)
379            (setf (vop-prev before) last))
380          (let ((current (ir2-block-last-vop block)))
381            (setf (vop-prev first) current)
382            (setf (ir2-block-last-vop block) last)
383            (if current
384                (setf (vop-next current) first)
385                (setf (ir2-block-start-vop block) first))))
386      (undefined-value))
387    
388    
389    ;;; DELETE-VOP  --  Interface
390    ;;;
391    ;;;    Delete all of the TN-Refs associated with VOP and remove VOP from the
392    ;;; IR2.
393    ;;;
394    (defun delete-vop (vop)
395      (declare (type vop vop))
396      (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
397          ((null ref))
398        (delete-tn-ref ref))
399    
400      (let ((prev (vop-prev vop))
401            (next (vop-next vop))
402            (block (vop-block vop)))
403        (if prev
404            (setf (vop-next prev) next)
405            (setf (ir2-block-start-vop block) next))
406        (if next
407            (setf (vop-prev next) prev)
408            (setf (ir2-block-last-vop block) prev)))
409    
410      (undefined-value))
411    
412    
413  ;;; Make-N-TNs  --  Interface  ;;; Make-N-TNs  --  Interface
414  ;;;  ;;;
415  ;;;    Return a list of N normal TNs of the specified primitive type.  ;;;    Return a list of N normal TNs of the specified primitive type.
# Line 300  Line 448 
448    
449  ;;; Force-TN-To-Stack  --  Interface  ;;; Force-TN-To-Stack  --  Interface
450  ;;;  ;;;
451  ;;;    Force TN not to be allocated in a register by clearing the cost for each  ;;;    Force TN to be allocated in a SC that doesn't need to be saved: an
452  ;;; SC that has a Save-SC.  ;;; unbounded non-save-p SC.  We don't actually make it a real "restricted" TN,
453    ;;; but since we change the SC to an unbounded one, we should always succeed in
454    ;;; packing it in that SC.
455  ;;;  ;;;
456  (defun force-tn-to-stack (tn)  (defun force-tn-to-stack (tn)
457    (declare (type tn tn))    (declare (type tn tn))
458    (let ((costs (tn-costs tn)))    (let ((sc (tn-sc tn)))
459      (dotimes (i sc-number-limit)      (unless (and (not (sc-save-p sc))
460        (when (svref *save-scs* i)                   (eq (sb-kind (sc-sb sc)) :unbounded))
461          (setf (svref costs i) nil))))        (dolist (alt (sc-alternate-scs sc)
462                       (error "SC ~S has no :unbounded :save-p NIL alternate SC."
463                              (sc-name sc)))
464            (when (and (not (sc-save-p alt))
465                       (eq (sb-kind (sc-sb alt)) :unbounded))
466              (setf (tn-sc tn) alt)
467              (return)))))
468    (undefined-value))    (undefined-value))
469    
470    
471  ;;; TN-Environment  --  Interface  ;;; TN-Environment  --  Interface
472  ;;;  ;;;
473  ;;;    Return some IR2-Environment that TN is referenced in.  TN must have at  ;;;    Return some Environment that TN is referenced in.  TN must have at least
474  ;;; least one reference (either read or write.)  Note that some TNs are  ;;; one reference (either read or write.)  Note that some TNs are referenced in
475  ;;; referenced in multiple environments.  ;;; multiple environments.
476  ;;;  ;;;
477  (defun tn-environment (tn)  (defun tn-environment (tn)
478    (declare (type tn tn))    (declare (type tn tn))
479    (let ((ref (or (tn-reads tn) (tn-writes tn))))    (let ((ref (or (tn-reads tn) (tn-writes tn))))
480      (assert ref)      (assert ref)
481      (environment-info      (lambda-environment
482       (lambda-environment       (block-lambda
483        (block-lambda        (ir2-block-block (vop-block (tn-ref-vop ref)))))))
        (ir2-block-block (vop-block (tn-ref-vop ref))))))))  

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5