Skip to content
Snippets Groups Projects
Commit 10f9de4b authored by ram's avatar ram
Browse files

Merged non-descriptor changes:

 revision 1.1.1.4
 date: 90/04/13 12:42:16;  author: ram;  state: Exp;  lines added/del: 25/10
 Added EMIT-CONTEXT-TEMPLATE.  Fixed some random bugs.  Changed stuff
 to deal with TN-ENVIRONMENT returning an IR1 environment.
 ----------------------------
 revision 1.1.1.3
 date: 90/04/02 15:20:09;  author: ram;  state: Exp;  lines added/del: 36/33
 Eliminated cross-product problems with the MAKE-xxx-TN functions by
 splitting the ENVIRONMENT/COMPONENT live aspect of TNs off into
 separate functions.  Changed FORCE-TN-TO-STACK to work with the new
 alternate SC mechanism.
 ----------------------------
 revision 1.1.1.2
 date: 90/03/27 12:40:37;  author: ram;  state: Exp;  lines added/del: 142/0
 Changed MAKE-RESTRICTED-TN to take a single SC number instead of a listof SC numbers. Added MAKE-REPRESENTATION-TN.Changed MAKE-WIRED-TN and MAKE-WIRED-ENVIRONMENT-TN to no longer take
 a primitive type.
  Moved EMIT-MOVE-TEMPLATE here from IR2tran.  Added EMIT-MOVE-ARG-TEMPLATE
  and EMIT-LOAD-TEMPLATE.  Made these functions return the last VOP
  inserted.
 Moved BLOCK-LABEL, DROP-THRU-P and INSERT-VOP-SEQUENCE here.
 Added DELETE-VOP.
 ----------------------------
 revision 1.1.1.1
 date: 90/03/08 14:01:45;  author: ram;  state: Exp;  lines added/del: 12/17
 Start work on better non-descriptor support.
parent 42ca2f8e
No related branches found
No related tags found
No related merge requests found
...@@ -77,41 +77,34 @@ ...@@ -77,41 +77,34 @@
(declare (type primitive-type type)) (declare (type primitive-type type))
(let* ((component (component-info *compile-component*)) (let* ((component (component-info *compile-component*))
(res (make-tn (incf (ir2-component-global-tn-counter component)) (res (make-tn (incf (ir2-component-global-tn-counter component))
:normal type nil)) :normal type nil)))
(costs (tn-costs res)))
(dolist (scn (primitive-type-scs type))
(setf (svref costs scn) 0))
(push-in tn-next res (ir2-component-normal-tns component)) (push-in tn-next res (ir2-component-normal-tns component))
res)) res))
;;; Make-Environment-TN -- Interface ;;; Make-Restricted-TN -- Interface
;;; ;;;
;;; 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.
;;; ;;;
(defun make-environment-tn (type env) (defun make-restricted-tn (scn)
(declare (type primitive-type type) (type environment env)) (declare (type sc-number scn))
(let ((res (make-normal-tn type))) (let* ((component (component-info *compile-component*))
(setf (tn-kind res) :environment) (res (make-tn (incf (ir2-component-global-tn-counter component))
(push res (ir2-environment-live-tns (environment-info env))) :normal nil (svref *sc-numbers* scn))))
(push-in tn-next res (ir2-component-restricted-tns component))
res)) res))
;;; Make-Restricted-TN -- Interface ;;; MAKE-REPRESENTATION-TN -- Interface
;;; ;;;
;;; 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.
;;; ;;;
(defun make-restricted-tn (type scs) (defun make-representation-tn (scn)
(declare (type primitive-type type) (type list scs)) (declare (type sc-number scn))
(let* ((component (component-info *compile-component*)) (let* ((component (component-info *compile-component*))
(res (make-tn (incf (ir2-component-global-tn-counter component)) (res (make-tn (incf (ir2-component-global-tn-counter component))
:normal type nil)) :normal nil (svref *sc-numbers* scn))))
(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))
res)) res))
...@@ -119,31 +112,41 @@ ...@@ -119,31 +112,41 @@
;;; ;;;
;;; 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
;;; 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
;;; Wired-TNs list. Type is used to determine the move/coerce operations. ;;; Wired-TNs list.
;;; ;;;
(defun make-wired-tn (type scn offset) (defun make-wired-tn (scn offset)
(declare (type primitive-type type) (type sc-number scn) (declare (type sc-number scn) (type unsigned-byte offset))
(type unsigned-byte offset))
(let* ((component (component-info *compile-component*)) (let* ((component (component-info *compile-component*))
(res (make-tn (incf (ir2-component-global-tn-counter component)) (res (make-tn (incf (ir2-component-global-tn-counter component))
:normal type (svref *sc-numbers* scn)))) :normal nil (svref *sc-numbers* scn))))
(setf (tn-offset res) offset) (setf (tn-offset res) offset)
(push-in tn-next res (ir2-component-wired-tns component)) (push-in tn-next res (ir2-component-wired-tns component))
res)) res))
;;; Make-Wired-Environment-TN -- Interface ;;; Environment-Live-TN -- Interface
;;; ;;;
;;; 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
;;; specified Environment. ;;; Env. Return TN.
;;; ;;;
(defun make-wired-environment-tn (type scn offset env) (defun environment-live-tn (tn env)
(declare (type primitive-type type) (type sc-number scn) (declare (type tn tn) (type environment env))
(type unsigned-byte offset) (type environment env)) (assert (eq (tn-kind tn) :normal))
(let ((res (make-wired-tn type scn offset))) (setf (tn-kind tn) :environment)
(setf (tn-kind res) :environment) (push tn (ir2-environment-live-tns (environment-info env)))
(push res (ir2-environment-live-tns (environment-info env))) tn)
res))
;;; Component-Live-TN -- Interface
;;;
;;; Make TN be live throughout the current component. Return TN.
;;;
(defun component-live-tn (tn)
(declare (type tn tn))
(assert (eq (tn-kind tn) :normal))
(setf (tn-kind tn) :component)
(push tn (ir2-component-component-tns (component-info *compile-component*)))
tn)
;;; Make-Constant-TN -- Interface ;;; Make-Constant-TN -- Interface
...@@ -262,6 +265,151 @@ ...@@ -262,6 +265,151 @@
;;;; Random utilities: ;;;; Random utilities:
;;; Emit-Move-Template -- Internal
;;;
;;; Emit a move-like template determined at run-time, with X as the argument
;;; and Y as the result. Useful for move, coerce and type-check templates. If
;;; supplied, then insert before VOP, otherwise insert at then end of the
;;; block. Returns the last VOP inserted.
;;;
(defun emit-move-template (node block template x y &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn x y))
(let ((arg (reference-tn x nil))
(result (reference-tn y t)))
(multiple-value-bind
(first last)
(funcall (template-emit-function template) node block template arg
result)
(insert-vop-sequence first last block before)
last)))
;;; EMIT-LOAD-TEMPLATE -- Internal
;;;
;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
;;;
(defun emit-load-template (node block template x y info &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn x y))
(let ((arg (reference-tn x nil))
(result (reference-tn y t)))
(multiple-value-bind
(first last)
(funcall (template-emit-function template) node block template arg
result info)
(insert-vop-sequence first last block before)
last)))
;;; EMIT-MOVE-ARG-TEMPLATE -- Internal
;;;
;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
;;;
(defun emit-move-arg-template (node block template x f y &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn x f y))
(let ((x-ref (reference-tn x nil))
(f-ref (reference-tn f nil))
(y-ref (reference-tn y t)))
(setf (tn-ref-across x-ref) f-ref)
(multiple-value-bind
(first last)
(funcall (template-emit-function template) node block template x-ref
y-ref)
(insert-vop-sequence first last block before)
last)))
;;; EMIT-CONTEXT-TEMPLATE -- Internal
;;;
;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
;;;
(defun emit-context-template (node block template y &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn y))
(let ((y-ref (reference-tn y t)))
(multiple-value-bind
(first last)
(funcall (template-emit-function template) node block template nil
y-ref)
(insert-vop-sequence first last block before)
last)))
;;; Block-Label -- Interface
;;;
;;; Return the label marking the start of Block, assigning one if necessary.
;;;
(defun block-label (block)
(declare (type cblock block))
(let ((2block (block-info block)))
(or (ir2-block-%label 2block)
(setf (ir2-block-%label 2block) (gen-label)))))
;;; Drop-Thru-P -- Interface
;;;
;;; Return true if Block is emitted immediately after the block ended by
;;; Node.
;;;
(defun drop-thru-p (node block)
(declare (type node node) (type cblock block))
(let ((next-block (ir2-block-next (block-info (node-block node)))))
(assert (eq node (block-last (node-block node))))
(eq next-block (block-info block))))
;;; Insert-VOP-Sequence -- Interface
;;;
;;; Link a list of VOPs from First to Last into Block, Before the specified
;;; VOP. If Before is NIL, insert at the end.
;;;
(defun insert-vop-sequence (first last block before)
(declare (type vop first last) (type ir2-block block)
(type (or vop null) before))
(if before
(let ((prev (vop-prev before)))
(setf (vop-prev first) prev)
(if prev
(setf (vop-next prev) first)
(setf (ir2-block-start-vop block) first))
(setf (vop-next last) before)
(setf (vop-prev before) last))
(let ((current (ir2-block-last-vop block)))
(setf (vop-prev first) current)
(setf (ir2-block-last-vop block) last)
(if current
(setf (vop-next current) first)
(setf (ir2-block-start-vop block) first))))
(undefined-value))
;;; DELETE-VOP -- Interface
;;;
;;; Delete all of the TN-Refs associated with VOP and remove VOP from the
;;; IR2.
;;;
(defun delete-vop (vop)
(declare (type vop vop))
(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
((null ref))
(delete-tn-ref ref))
(let ((prev (vop-prev vop))
(next (vop-next vop))
(block (vop-block vop)))
(if prev
(setf (vop-next prev) next)
(setf (ir2-block-start-vop block) next))
(if next
(setf (vop-prev next) prev)
(setf (ir2-block-last-vop block) prev)))
(undefined-value))
;;; Make-N-TNs -- Interface ;;; Make-N-TNs -- Interface
;;; ;;;
;;; Return a list of N normal TNs of the specified primitive type. ;;; Return a list of N normal TNs of the specified primitive type.
...@@ -300,29 +448,36 @@ ...@@ -300,29 +448,36 @@
;;; Force-TN-To-Stack -- Interface ;;; Force-TN-To-Stack -- Interface
;;; ;;;
;;; 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
;;; SC that has a Save-SC. ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
;;; but since we change the SC to an unbounded one, we should always succeed in
;;; packing it in that SC.
;;; ;;;
(defun force-tn-to-stack (tn) (defun force-tn-to-stack (tn)
(declare (type tn tn)) (declare (type tn tn))
(let ((costs (tn-costs tn))) (let ((sc (tn-sc tn)))
(dotimes (i sc-number-limit) (unless (and (not (sc-save-p sc))
(when (svref *save-scs* i) (eq (sb-kind (sc-sb sc)) :unbounded))
(setf (svref costs i) nil)))) (dolist (alt (sc-alternate-scs sc)
(error "SC ~S has no :unbounded :save-p NIL alternate SC."
(sc-name sc)))
(when (and (not (sc-save-p alt))
(eq (sb-kind (sc-sb alt)) :unbounded))
(setf (tn-sc tn) alt)
(return)))))
(undefined-value)) (undefined-value))
;;; TN-Environment -- Interface ;;; TN-Environment -- Interface
;;; ;;;
;;; 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
;;; 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
;;; referenced in multiple environments. ;;; multiple environments.
;;; ;;;
(defun tn-environment (tn) (defun tn-environment (tn)
(declare (type tn tn)) (declare (type tn tn))
(let ((ref (or (tn-reads tn) (tn-writes tn)))) (let ((ref (or (tn-reads tn) (tn-writes tn))))
(assert ref) (assert ref)
(environment-info (lambda-environment
(lambda-environment (block-lambda
(block-lambda (ir2-block-block (vop-block (tn-ref-vop ref)))))))
(ir2-block-block (vop-block (tn-ref-vop ref))))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment