From 52f90d2836162b725eac32c26f2b591c6bb0e87f Mon Sep 17 00:00:00 2001 From: jgarcia Date: Mon, 12 Jun 2006 08:52:22 +0000 Subject: [PATCH] Add records to the compiler environment. --- src/cmp/cmpblock.lsp | 80 +++++++++++++++++++------------------------- src/cmp/cmpcatch.lsp | 4 +-- src/cmp/cmpdefs.lsp | 6 ---- src/cmp/cmplam.lsp | 1 - src/cmp/cmptop.lsp | 3 +- 5 files changed, 37 insertions(+), 57 deletions(-) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 98fe2eaaa..626c7d8e7 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -12,19 +12,14 @@ (in-package "COMPILER") -;;; During Pass 1, *blocks* holds a list of blk objects and the -;;; symbols 'CB' (Closure Boundary), 'LB' (Level Boundary) or -;;; 'UNWIND-PROTECT'. 'CB' will be pushed on *blocks* when the -;;; compiler begins to process a closure. 'LB' will be pushed on -;;; *blocks* when *level* is incremented. 'UNWIND-PROTECT' is pushed -;;; when entering an unwind-protect. A dummy variable is created to -;;; hold the block identifier. When a reference to the block (via -;;; return-from) is found, the var-ref count for that variable is -;;; incremented only if the reference appears across a boundary (CB, -;;; LB or UNWIND-PROTECT), while the blk-ref is always incremented. -;;; Therefore blk-ref represents whether the block is used at all and -;;; var-ref for the dummy variable represents whether a block -;;; identifier must be created and stored in such variable. +;;; A dummy variable is created to hold the block identifier. When a +;;; reference to the block (via return-from) is found, the var-ref +;;; count for that variable is incremented only if the reference +;;; appears across a boundary (CB, LB or UNWIND-PROTECT), while the +;;; blk-ref is always incremented. Therefore blk-ref represents +;;; whether the block is used at all and var-ref for the dummy +;;; variable represents whether a block identifier must be created and +;;; stored in such variable. (defun c1block (args) (check-args-number 'BLOCK args 1) @@ -33,8 +28,9 @@ (cmperr "The block name ~s is not a symbol." block-name)) (let* ((blk-var (make-var :name block-name :kind 'LEXICAL)) (blk (make-blk :var blk-var :name block-name)) - (*blocks* (cons blk *blocks*)) - (body (c1progn (rest args)))) + (body (let ((*cmp-env* (cmp-env-copy))) + (cmp-env-register-block blk) + (c1progn (rest args))))) (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) (incf *setjmps*)) (if (plusp (blk-ref blk)) @@ -78,36 +74,30 @@ (defun c1return-from (args) (check-args-number 'RETURN-FROM args 1 2) - (unless (symbolp (car args)) - (cmperr "The block name ~s is not a symbol." (car args))) - (do ((blks *blocks* (cdr blks)) - (name (car args)) - (ccb) (clb) (unw) (blk) (type T)) - ((endp blks) - (cmperr "The block ~s is undefined." name)) - (setq blk (car blks)) - (case blk - (CB (setq ccb t)) - (LB (setq clb t)) - (UNWIND-PROTECT (setq unw T)) - (t (when (eq (blk-name blk) name) - (let* ((val (c1expr (second args))) - (var (blk-var blk))) - (cond (ccb (setf (blk-ref-ccb blk) t - type 'CCB - (var-kind var) 'CLOSURE - (var-ref-ccb var) T) - (incf (var-ref var))) - (clb (setf (blk-ref-clb blk) t - type 'CLB) - (incf (var-ref var))) - (unw (setf type 'UNWIND-PROTECT) - (incf (var-ref var)))) - (incf (blk-ref blk)) - (setf (blk-type blk) (type-or (blk-type blk) (c1form-primary-type val))) - (return (add-to-read-nodes var (make-c1form* 'RETURN-FROM :type 'T - :args blk type val)))) - ))))) + (let ((name (first args))) + (unless (symbolp name) + (cmperr "The block name ~s is not a symbol." name)) + (multiple-value-bind (blk ccb clb unw) + (cmp-env-search-block name) + (unless blk + (cmperr "The block ~s is undefined." name)) + (let* ((val (c1expr (second args))) + (var (blk-var blk)) + (type T)) + (cond (ccb (setf (blk-ref-ccb blk) t + type 'CCB + (var-kind var) 'CLOSURE + (var-ref-ccb var) T) + (incf (var-ref var))) + (clb (setf (blk-ref-clb blk) t + type 'CLB) + (incf (var-ref var))) + (unw (setf type 'UNWIND-PROTECT) + (incf (var-ref var)))) + (incf (blk-ref blk)) + (setf (blk-type blk) (type-or (blk-type blk) (c1form-primary-type val))) + (add-to-read-nodes var (make-c1form* 'RETURN-FROM :type 'T + :args blk type val)))))) (defun c2return-from (blk type val) (case type diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 343c40c97..f7e118bc9 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -48,9 +48,7 @@ (check-args-number 'UNWIND-PROTECT args 1) (incf *setjmps*) (let (form) - (let ((*blocks* (cons 'UNWIND-PROTECT *blocks*)) - ;;(*vars* (cons 'LB *vars*)) - (*cmp-env* (cmp-env-mark 'UNWIND-PROTECT))) + (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT))) (setq form (c1expr (first args)))) (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t :args form (c1progn (rest args))))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index f47e81b5a..d5df54c7d 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -270,12 +270,6 @@ The default value is NIL.") (defvar *compiler-output1*) (defvar *compiler-output2*) -;;; --cmpblock.lsp-- -;;; -;;; List of defined blocks, including marks for boundaries of closures -;;; -(defvar *blocks* nil) - ;;; --cmpcbk.lsp-- ;;; ;;; List of callbacks to be generated diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 7c2f49689..2ed9094d1 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -74,7 +74,6 @@ (let* ((*current-function* fun) (*vars* (cons CB/LB *vars*)) (*cmp-env* (cmp-env-mark CB/LB)) - (*blocks* (cons CB/LB *blocks*)) (setjmps *setjmps*) (decl (si::process-declarations (rest lambda-list-and-body))) (lambda-expr (c1lambda-expr lambda-list-and-body diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index dc932ad9d..fdd672d47 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -14,8 +14,7 @@ (defun t1expr (form) (let ((*vars* nil) - (*cmp-env* (cmp-env-new)) - (*blocks* nil)) + (*cmp-env* (cmp-env-new))) (push (t1expr* form) *top-level-forms*))) (defvar *toplevel-forms-to-print*