From 858c678d3101a5a44371c26106a151291d346e88 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 15 Feb 1990 11:18:50 +0000 Subject: [PATCH] Fixed stuff so that we can make locals be allocated in environment TNs. Instead of doing two passes over the environments, we do only one, and assign the IR2 environment before the lambda-var TNs, rather than vice-versa. The only reason for doing two passes was to allow the primitive type of variables to be gotten from the TN (thus avoiding duplicated calls to PRIMITIVE-TYPE), but this doesn't seem to be a big deal. --- compiler/gtn.lisp | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/compiler/gtn.lisp b/compiler/gtn.lisp index 042435a0c..3a69161fd 100644 --- a/compiler/gtn.lisp +++ b/compiler/gtn.lisp @@ -22,21 +22,20 @@ ;;; GTN-Analyze -- Interface ;;; -;;; We make two passes over the component's environments. First we assign -;;; TNs for local variables, then we assign argument passing locations and -;;; return conventions. +;;; We make a pass over the component's environments, assigning argument +;;; passing locations and return conventions and TNs for local variables. ;;; (defun gtn-analyze (component) (setf (component-info component) (make-ir2-component)) (let ((funs (component-lambdas component))) - (dolist (fun funs) - (assign-lambda-var-tns fun nil) - (dolist (let (lambda-lets fun)) - (assign-lambda-var-tns let t))) (dolist (fun funs) (assign-ir2-environment fun) (assign-return-locations fun) - (assign-ir2-nlx-info fun))) + (assign-ir2-nlx-info fun) + (assign-lambda-var-tns fun nil) + (dolist (let (lambda-lets fun)) + (assign-lambda-var-tns let t)))) + (undefined-value)) @@ -59,7 +58,7 @@ (res (if (or let-p (policy (lambda-bind fun) (= speed 3))) (make-normal-tn type) - (make-environment-tn type)))) + (make-environment-tn type (lambda-environment fun))))) (setf (tn-leaf res) var) (setf (leaf-info var) res)))) (undefined-value)) @@ -87,12 +86,12 @@ (if (minusp i) (make-argument-count-location) (standard-argument-location i)) - (make-normal-tn #|(tn-primitive-type (leaf-info var))||# + (make-normal-tn #|(primitive-type (leaf-type var))||# *any-primitive-type*)))))) (dolist (thing (environment-closure env)) (let ((ptype (etypecase thing - (lambda-var (tn-primitive-type (leaf-info thing))) + (lambda-var (primitive-type (leaf-type thing))) (nlx-info *any-primitive-type*)))) (unless xep-p (args (make-normal-tn ptype))) -- GitLab