From fc8deffa7147b40aa8c5ab77d089e36c81d8327f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 22 Oct 2003 07:27:44 +0000 Subject: [PATCH] src/c --- src/cmp/cmpbind.lsp | 63 ++++++++++++++++++------------------ src/cmp/cmpblock.lsp | 17 +--------- src/cmp/cmpdefs.lsp | 36 ++++++++++----------- src/cmp/cmpenv.lsp | 7 ---- src/cmp/cmpflet.lsp | 27 +++------------- src/cmp/cmplam.lsp | 2 +- src/cmp/cmplet.lsp | 26 ++++++++------- src/cmp/cmpmulti.lsp | 2 +- src/cmp/cmptag.lsp | 22 ++----------- src/cmp/cmptop.lsp | 54 ++----------------------------- src/cmp/cmputil.lsp | 1 - src/cmp/cmpvar.lsp | 73 +++++++++++++----------------------------- src/cmp/cmpwt.lsp | 17 ---------- src/h/internal.h | 3 ++ src/lsp/defmacro.lsp | 2 +- src/lsp/defpackage.lsp | 7 ++-- src/lsp/evalmacros.lsp | 4 +-- src/lsp/export.lsp | 6 ++-- 18 files changed, 112 insertions(+), 257 deletions(-) diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index 69404a08b..55413821d 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -22,27 +22,27 @@ ;; a constant, or (VAR var) from a let binding. ; ccb (declare (type var var)) (case (var-kind var) + (CLOSURE + (let ((var-loc (var-loc var))) + (unless (sys:fixnump var-loc) + ;; first binding: assign location + (setq var-loc (next-env)) + (setf (var-loc var) var-loc)) + (when (zerop var-loc) (wt-nl "env" *env-lvl* " = Cnil;")) + (wt-nl "CLV" var-loc "=&CAR(env" *env-lvl* "=CONS(") + (wt-coerce-loc :object loc) + (wt ",env" *env-lvl* "));") + (wt-comment (var-name var)))) (LEXICAL (let ((var-loc (var-loc var))) - (if (var-ref-ccb var) - (progn - (unless (sys:fixnump var-loc) - ;; first binding: assign location - (setq var-loc (next-env)) - (setf (var-loc var) var-loc)) - (when (zerop var-loc) (wt-nl "env" *env-lvl* " = Cnil;")) - (wt-nl "CLV" var-loc "=&CAR(env" *env-lvl* "=CONS(") - (wt-coerce-loc :object loc) - (wt ",env" *env-lvl* "));")) - (progn - (unless (consp var-loc) - ;; first binding: assign location - (setq var-loc (next-lex)) - (setf (var-loc var) var-loc)) - (wt-nl) (wt-lex var-loc) (wt "= ") - (wt-coerce-loc :object loc) - (wt ";"))) - (wt-comment (var-name var)))) + (unless (consp var-loc) + ;; first binding: assign location + (setq var-loc (next-lex)) + (setf (var-loc var) var-loc)) + (wt-nl) (wt-lex var-loc) (wt "= ") + (wt-coerce-loc :object loc) + (wt ";")) + (wt-comment (var-name var))) (SPECIAL (bds-bind loc var)) (t @@ -67,15 +67,16 @@ ;; otherwise the increment to *env* or *lex* is done during ;; unwind-exit and will be shadowed by functions (like c2let) ;; which rebind *env* or *lex*. - (when (eq (var-kind var) 'LEXICAL) - (if (var-ref-ccb var) - (unless (si:fixnump (var-loc var)) - (setf (var-loc var) (next-env))) - (unless (consp (var-loc var)) - (setf (var-loc var) (next-lex))))) - (when (eq (var-kind var) 'SPECIAL) - ;; prevent BIND from pushing BDS-BIND - (setf (var-ref-ccb var) t)) + (case (var-kind var) + (CLOSURE + (unless (si:fixnump (var-loc var)) + (setf (var-loc var) (next-env)))) + (LEXICAL + (unless (consp (var-loc var)) + (setf (var-loc var) (next-lex)))) + (SPECIAL + ;; prevent BIND from pushing BDS-BIND + (setf (var-bds-bound var) t))) (c2expr* form) (when (eq (var-kind var) 'SPECIAL) ;; now the binding is in effect @@ -94,10 +95,10 @@ ;; push BDS-BIND only once: ;; bds-bind may be called several times on the same variable, e.g. ;; an optional has two alternative bindings. - ;; We use field var-ref-ccb to record this fact. - (unless (var-ref-ccb var) + ;; We use field var-bds-bound to record this fact. + (unless (var-bds-bound var) (push 'BDS-BIND *unwind-exit*) - (setf (var-ref-ccb var) t)) + (setf (var-bds-bound var) t)) (wt-comment (var-name var))) (put-sysprop 'BIND 'SET-LOC 'bind) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index c4541ca92..1923443c9 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -12,22 +12,6 @@ (in-package "COMPILER") -#| -;;; Use a structure of type vector to avoid creating -;;; normal structures before booting CLOS: -(defstruct (blk (:type vector) :named) - name ;;; Block name. - (ref 0 :type fixnum) ;;; Number of references. - ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. - ;;; block id, or NIL. - exit ;;; Where to return. A label. - destination ;;; Where the value of the block to go. - var ;;; variable containing the block ID. -) |# - ;;; 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 @@ -109,6 +93,7 @@ (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 diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index d16f95051..7e6a82022 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -38,6 +38,10 @@ ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the index into the closure env + ref-clb ;;; Cross local function reference. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the lex-address for the + ;;; block id, or NIL. ) (deftype OBJECT () `(not (or fixnum character short-float long-float))) @@ -46,9 +50,9 @@ ; name ;;; Variable name. ; (ref 0 :type fixnum) ;;; Number of references to the variable (-1 means IGNORE). - ;;; During Pass 2: set below *register-min* for non register. ; ref-ccb ;;; Cross closure reference: T or NIL. - kind ;;; One of LEXICAL, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, +; ref-clb ;;; Cross local function reference: T or NIL. + kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, ;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for ;;; LET variables). (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can @@ -63,12 +67,12 @@ ;;; For REPLACED: the actual location of the variable. ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: ;;; the cvar for the C variable that holds the value. - ;;; For LEXICAL: the frame-relative address for the variable. + ;;; For LEXICAL or CLOSURE: the frame-relative address for the variable. ;;; For SPECIAL and GLOBAL: the vv-index for variable name. (type t) ;;; Type of the variable. (index -1) ;;; position in *vars*. Used by similar. + (bds-bound nil) ;;; BDS-BIND was already used on this variable. ) -;(deftype var () '(satisfies var-p)) ;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE ;;; Here are examples of function FOO for the 3 cases: @@ -104,8 +108,14 @@ (defstruct (fun (:include ref)) ; name ;;; Function name. ; (ref 0 :type fixnum) ;;; Number of references. + ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the + ;;; function closure, or NIL. ; ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. + ;;; During Pass2, the vs-address for the function + ;;; closure, or NIL. +; ref-clb ;;; Unused. cfun ;;; The cfun for the function. (level 0) ;;; Level of lexical nesting for a function. (env 0) ;;; Size of env of closure. @@ -113,7 +123,6 @@ var ;;; the variable holding the funob description ;;; Text for the object, in case NAME == NIL. ) -;(deftype fun () '(satisfies fun-p)) (defstruct (blk (:include ref)) ; name ;;; Block name. @@ -122,7 +131,7 @@ ;;; During Pass1, T or NIL. ;;; During Pass2, the ccb-lex for the ;;; block id, or NIL. - ref-clb ;;; Cross local function reference. +; ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. ;;; During Pass2, the lex-address for the ;;; block id, or NIL. @@ -131,21 +140,19 @@ var ;;; Variable containing the block ID. (type 'NIL) ;;; Estimated type. ) -;(deftype blk () '(satisfies blk-p)) (defstruct (tag (:include ref)) ; name ;;; Tag name. ; (ref 0 :type fixnum) ;;; Number of references. ; ref-ccb ;;; Cross closure reference. ;;; During Pass1, T or NIL. - ref-clb ;;; Cross local function reference. +; ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. label ;;; Where to jump: a label. unwind-exit ;;; Where to unwind-no-exit. var ;;; Variable containing frame ID. index ;;; An integer denoting the label. ) -;(deftype tag () '(satisfies tag-p)) (defstruct (info) (changed-vars nil) ;;; List of var-objects changed by the form. @@ -163,7 +170,6 @@ ;;; add-info) so that we can determine exactly which frame is used ;;; in the body of a function. ) -;(deftype info () '(satisfies info-p)) ;;; ;;; VARIABLES @@ -243,7 +249,7 @@ The default value is NIL.") ;;; ;;; Compiled code uses the following kinds of variables: -;;; 1. Vi, declared explicitely, either unboxed or register (*lcl*, next-lcl) +;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) ;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp) ;;; 4. lexi[j], for lexical variables in local functions ;;; 5. CLVi, for lexical variables in closures @@ -332,11 +338,6 @@ The default value is NIL.") ;;; --cmptop.lsp-- ;;; (defvar *funarg-vars*) -;;; Number of address registers available not counting the -;;; frame pointer and the stack pointer -;;; To do: If the regs hold data then there are really more available; -(defvar *free-address-registers* 5) -(defvar *free-data-registers* 6) (defvar *volatile*) (defvar *setjmps* 0) @@ -389,6 +390,3 @@ The default value is NIL.") (defvar *vars* nil) (defvar *undefined-vars* nil) (defvar *special-binding* nil) - -(defvar *register-min* 3) ; criteria for putting in register. -(proclaim '(fixnum *register-min*)) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 4878f1161..7e9627efe 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -339,13 +339,6 @@ "The object declaration ~s contains a non-symbol ~s." decl var) (push (cons var 'OBJECT) ts))) - (:REGISTER - (dolist (var (cdr decl)) - (cmpck (not (symbolp var)) - "The register declaration ~s contains a non-symbol ~s." - decl var) - (push (cons var 'REGISTER) ts) - )) ;; read-only variable treatment. Beppe (:READ-ONLY #| obsolete diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 42eb26b21..3a003afe4 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -12,26 +12,6 @@ (in-package "COMPILER") -#| -;;; Use a structure of type vector to avoid creating -;;; normal structures before booting CLOS: -(defstruct (fun (:type vector) :named) - name ;;; Function name. - ref ;;; Referenced or not. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the vs-address for the - ;;; function closure, or NIL. - ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the vs-address for the - ;;; function closure, or NIL. - cfun ;;; The cfun for the function. - level ;;; Level of nesting for a function. - env ;;; Size of env of closure. - closure ;;; During Pass1, T if the function is returned - ;;; During Pass2, T if env is used inside the function - ) |# - (defun c1flet (args &aux body ss ts is other-decl (defs nil) (local-funs nil)) (check-args-number 'FLET args 1) @@ -103,7 +83,7 @@ (dolist (def funs) (let* ((fun (car def)) (var (fun-var fun))) (when (plusp (var-ref var)) ; the function is returned - (unless (eq 'LEXICAL (var-kind var)) + (unless (member (var-kind var) '(LEXICAL CLOSURE)) (setf (var-loc var) (next-lcl)) (unless block-p (setq block-p t) (wt-nl "{ ")) @@ -267,9 +247,10 @@ (setf (fun-var fun) (make-var :name fname :kind :OBJECT))))) (cond (ccb (setf (var-ref-ccb var) t - (var-kind var) 'LEXICAL) + (var-kind var) 'CLOSURE) (setf (fun-ref-ccb fun) t)) - (clb (setf (var-kind var) 'LEXICAL)))) + (clb (setf (var-ref-clb var) t + (var-kind var) 'LEXICAL)))) (return fun))))) (defun c1call-local (fname) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 4313ea70f..a0c291de3 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -196,7 +196,7 @@ (declare (fixnum lcl)) (labels ((wt-decl (var) (wt-nl) - (wt *volatile* (register var) (rep-type-name (var-rep-type var)) " ") + (wt *volatile* (rep-type-name (var-rep-type var)) " ") (wt-lcl (incf lcl)) (wt ";") `(LCL ,lcl)) (do-decl (var) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index ce6793ac9..45bdd7215 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -145,8 +145,7 @@ (wt-nl) (unless block-p (wt "{") (setq block-p t)) - (wt *volatile* (register var) (rep-type-name (var-rep-type var)) " " - var ";") + (wt *volatile* (rep-type-name (var-rep-type var)) " " var ";") (when (local var) (wt-comment (var-name var)))) (do-init (var form fl) @@ -188,9 +187,11 @@ (and (member (var-kind var1) '(SPECIAL GLOBAL)) (member (var-name var1) prev-ss))) (do-init var form fl)) - ((and (can-be-replaced var body) - (member (var-kind var1) '(LEXICAL REPLACED :OBJECT)) - (not (var-ref-ccb var1)) + ((and ;; Fixme! We should be able to replace variable + ;; even if they are referenced across functions. + ;; We just need to keep track of their uses. + (member (var-kind var1) '(REPLACED :OBJECT)) + (can-be-replaced var body) (not (member var1 (c1form-changed-vars body)))) (setf (var-kind var) 'REPLACED (var-loc var) var1)) @@ -365,7 +366,7 @@ var (car vl) kind (local var)) (unless (unboxed var) - ;; LEXICAL, SPECIAL, GLOBAL or OBJECT + ;; LEXICAL, CLOSURE, SPECIAL, GLOBAL or OBJECT (case (c1form-name form) (LOCATION (when (can-be-replaced* var body (cdr fl)) @@ -374,9 +375,11 @@ (VAR (let* ((var1 (c1form-arg 0 form))) (declare (type var var1)) - (when (and (can-be-replaced* var body (cdr fl)) - (member (var-kind var1) '(LEXICAL REPLACED :OBJECT)) - (not (var-ref-ccb var1)) + (when (and ;; Fixme! We should be able to replace variable + ;; even if they are referenced across functions. + ;; We just need to keep track of their uses. + (member (var-kind var1) '(REPLACED :OBJECT)) + (can-be-replaced* var body (cdr fl)) (not (var-changed-in-forms var1 (cdr fl))) (not (member var1 (c1form-changed-vars body)))) (setf (var-kind var) 'REPLACED @@ -386,7 +389,7 @@ (when (and kind (not (eq (var-kind var) 'REPLACED))) (bind (next-lcl) var) (wt-nl) (unless block-p (wt "{") (setq block-p t)) - (wt *volatile* (register var) (rep-type-name kind) " " var ";") + (wt *volatile* (rep-type-name kind) " " var ";") (wt-comment (var-name var))) ) @@ -405,7 +408,7 @@ form (car fl)) (case (var-kind var) (REPLACED) - ((LEXICAL SPECIAL GLOBAL) + ((LEXICAL CLOSURE SPECIAL GLOBAL) (case (c1form-name form) (LOCATION (bind (c1form-arg 0 form) var)) (VAR (bind (c1form-arg 0 form) var)) @@ -438,7 +441,6 @@ (defun can-be-replaced (var body) (declare (type var var)) (and (eq (var-kind var) :OBJECT) - (< (var-ref var) *register-min*) (not (member var (c1form-changed-vars body))))) #| (and (or (eq (var-kind var) 'LEXICAL) (and (eq (var-kind var) :OBJECT) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 769515991..36f83b264 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -191,7 +191,7 @@ (if kind (progn (bind (next-lcl) var) - (wt-nl *volatile* (register var) (rep-type-name kind) " " var ";") + (wt-nl *volatile* (rep-type-name kind) " " var ";") (wt-comment (var-name var))) (unless env-grows (setq env-grows (var-ref-ccb var)))))) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index dc5f3c30e..f63745bb6 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -13,22 +13,6 @@ (in-package "COMPILER") -#| -;;; Use a structure of type vector to avoid creating -;;; normal structures before booting CLOS: -(defstruct (tag (:type vector) :named) - name ;;; Tag name. - (ref 0 :type fixnum) ;;; Number of references. - ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. - label ;;; Where to jump: a label. - unwind-exit ;;; Where to unwind-no-exit. - var ;;; Variable containing frame ID. - index ;;; Number of tag in the list. -) |# - ;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB' ;;; (Closure Boundary), 'LB' (Level Boundary) or 'UNWIND-PROTECT'. ;;; 'CB' will be pushed on *tags* when the compiler begins to process @@ -40,8 +24,7 @@ ;;; label in the body. ;;; When a reference to a tag (go instruction) is found, the ;;; var-kind is stepped from NIL to OBJECT (if appearing inside an -;;; unwind-protect) to LEXICAL (if appearing across a boundary: with -;;; var-ref-ccb set to T in case of closure boundary). +;;; unwind-protect) to LEXICAL or CLOSURE (if appearing across a boundary). ;;; The tag-ref is also incremented. ;;; Therefore var-ref represents whether some tag is used at all and var-kind ;;; variable represents whether a tag identifier must be created and the @@ -207,8 +190,9 @@ (setq var (tag-var tag)) (cond (ccb (setf (tag-ref-ccb tag) t (var-ref-ccb var) T - (var-kind var) 'LEXICAL)) + (var-kind var) 'CLOSURE)) (clb (setf (tag-ref-clb tag) t + (var-ref-clb var) t (var-kind var) 'LEXICAL)) (unw (unless (var-kind var) (setf (var-kind var) :OBJECT)))) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index d0e5f005e..4dfd5b800 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -29,10 +29,7 @@ (let ((fun (car form)) (args (cdr form)) fd setf-symbol) ; #+cltl2 (cond ((symbolp fun) - (cond ((get-sysprop fun 'PACKAGE-OPERATION) - (cmp-eval form) - (wt-data-package-operation form)) - ((setq fd (get-sysprop fun 'T1)) + (cond ((setq fd (get-sysprop fun 'T1)) (when *compile-print* (print-current-form)) (funcall fd args)) ((get-sysprop fun 'C1) (t1ordinary form)) @@ -314,12 +311,6 @@ "Number of proclaimed args for ~a was ~a. ~ ~%;;; Its definition had ~a." fname arg-p arg-c))))) -(defun register (var) - (if (and (equal *volatile* "") - (> (var-ref var) (the fixnum *register-min*))) - "register " - "")) - (defun t2defun (fname cfun lambda-expr sp funarg-vars no-entry) (declare (ignore sp funarg-vars)) (if no-entry @@ -344,7 +335,6 @@ (when lambda-expr ; Not sharing code. (setq lambda-list (c1form-arg 0 lambda-expr) requireds (car lambda-list)) - (analyze-regs (c1form-referred-vars lambda-expr)) (if (setq inline-info (assoc fname *inline-functions* :test #'same-fname-p)) @@ -380,7 +370,7 @@ ;; so that c2lambda-expr will know its proper type. (setf (var-kind var) rep-type)) (unless (eq vl requireds) (wt ",")) - (wt *volatile* (register var) (rep-type-name rep-type) " ") + (wt *volatile* (rep-type-name rep-type) " ") (wt-lcl lcl)) (wt ")")))) (wt-h string ";") @@ -462,39 +452,6 @@ (wt-h1 ";")) ) -;;; Checks the register slots of variables, and finds which -;;; variables should be in registers, reducing the var-ref value -;;; in the remaining. Data and address variables are done separately. -(defun analyze-regs (vars) - (flet ((analyze-regs1 (vars want &aux (tem 0) (real-min 3) (this-min 100000) - (have 0)) - (declare (fixnum want tem real-min this-min have)) - (do ((vs vars) (v)) - ((null vs)) - (setq v (pop vs) - tem (var-ref v)) - (when (>= tem real-min) - (incf have) - (setq this-min (min this-min tem)) - (when (> have want) - (setq have 0 - real-min (1+ this-min) - this-min 1000000 - vs vars)))) - (when (< have want) (decf real-min)) - (dolist (v vars) - (when (< (var-ref v) real-min) - ;; don't put 1, otherwise optimization may discard - ;; variable - (setf (var-ref v) (min (var-ref v) *register-min*)))))) - (let (addr data) - (dolist (v vars) - (if (member-type (var-type v) '(FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT)) - (pushnew v data) - (pushnew v addr))) - (analyze-regs1 addr *free-address-registers*) - (analyze-regs1 data *free-data-registers*)))) - (defun wt-global-entry (fname cfun arg-types return-type) (when (and (symbolp fname) (get-sysprop fname 'NO-GLOBAL-ENTRY)) (return-from wt-global-entry nil)) @@ -762,7 +719,6 @@ (wt-h1 ");") (wt ")") - (analyze-regs (c1form-referred-vars lambda-expr)) (let* ((*lcl* 0) (*temp* 0) (*max-temp* 0) (*lex* 0) (*max-lex* 0) (*env* (fun-env fun)) ; continue growing env @@ -972,9 +928,3 @@ ;(put-sysprop 'DEFENTRY 'T3 't3defentry) (put-sysprop 'DEFCBODY 'T3 't3defCbody) ; Beppe ;(put-sysprop 'DEFUNC 'T3 't3defunC) ; Beppe - -;;; Package operations. - -(put-sysprop 'si::select-package 'PACKAGE-OPERATION t) -(put-sysprop 'si::%defpackage 'PACKAGE-OPERATION t) - diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 2d8492df1..574824506 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -172,7 +172,6 @@ (defun si::compiler-clear-compiler-properties (symbol) #-:CCL ;(sys::unlink-symbol symbol) - (rem-sysprop symbol 'package-operation) (rem-sysprop symbol 't1) (rem-sysprop symbol 't2) (rem-sysprop symbol 't3) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 08d66e03f..c6a66dc24 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -12,36 +12,6 @@ (in-package "COMPILER") -#| -;;; Use a structure of type vector to avoid creating -;;; normal structures before booting CLOS: -(defstruct (var (:type vector) :named) - name ;;; Variable name. - (ref 0 :type fixnum) - ;;; Number of references to the variable (-1 means IGNORE). - ;;; During Pass 2: set below *register-min* for non register. - ref-ccb ;;; Cross closure reference: T or NIL. - kind ;;; One of LEXICAL, SPECIAL, GLOBAL, OBJECT, FIXNUM, - ;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, or REPLACED (used for - ;;; LET variables). - (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can - ;;; be allocated on the c-stack: OBJECT means - ;;; the variable is declared as OBJECT, and CLB means - ;;; the variable is referenced across Level Boundary and thus - ;;; cannot be allocated on the C stack. Note that OBJECT is - ;;; set during variable binding and CLB is set when the - ;;; variable is used later, and therefore CLB may supersede - ;;; OBJECT. - ;;; During Pass 2: - ;;; For REPLACED: the actual location of the variable. - ;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, OBJECT: - ;;; the cvar for the C variable that holds the value. - ;;; For LEXICAL: the frame-relative address for the variable. - ;;; For SPECIAL and GLOBAL: the vv-index for variable name. - (type t) ;;; Type of the variable. - (index -1) ;;; position in *vars*. Used by similar. - ) |# - ;;; A special binding creates a var object with the kind field SPECIAL, ;;; whereas a special declaration without binding creates a var object with ;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure @@ -110,11 +80,13 @@ (t (dolist (v types) (when (eq (car v) name) - (case (cdr v) + (setf (var-type var) (cdr v)) +; (case (cdr v) ; (OBJECT (setf (var-loc var) 'OBJECT)) - (REGISTER - (incf (var-ref var) 100)) - (t (setf (var-type var) (cdr v)))))) +; (REGISTER +; (incf (var-ref var) 100)) +; (t (setf (var-type var) (cdr v)))) + )) ; (when (or (null (var-type var)) ; (eq t (var-type var))) ; (setf (var-loc var) 'OBJECT)) @@ -127,11 +99,10 @@ ) (defun check-vref (var) - (when (and (eq (var-kind var) 'LEXICAL) - (not (var-ref-ccb var))) + (when (eq (var-kind var) 'LEXICAL) (when (zerop (var-ref var)) ;;; This field may be -1 (IGNORE). Beppe (cmpwarn "The variable ~s is not used." (var-name var))) - (when (not (eq (var-loc var) 'CLB)) + (when (not (var-ref-clb var)) ;; if the variable can be stored locally, set it var-kind to its type (setf (var-kind var) (if (> (var-ref var) 1) @@ -177,9 +148,12 @@ (cmpwarn "The ignored variable ~s is used." name) (setf (var-ref var) 0)) (when (eq (var-kind var) 'LEXICAL) - (cond (ccb (setf (var-ref-ccb var) t - (var-loc var) 'OBJECT)) ; replace a previous 'CLB - (clb (setf (var-loc var) 'CLB)))) + (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB + (var-ref-ccb var) t + (var-kind var) 'CLOSURE + (var-loc var) 'OBJECT)) + (clb (setf (var-ref-clb var) t + (var-loc var) 'OBJECT)))) (incf (var-ref var)) (return-from c1vref var)))) ; ccb (let ((var (sch-global name))) @@ -207,7 +181,7 @@ (not (eq (var-rep-type var) :object))) (defun local (var) - (and (not (member (var-kind var) '(LEXICAL SPECIAL GLOBAL REPLACED))) + (and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED))) (var-kind var))) (defun c2var (vref) (unwind-exit vref)) @@ -217,9 +191,8 @@ (defun wt-var (var &aux (var-loc (var-loc var))) ; ccb (declare (type var var)) (case (var-kind var) - (LEXICAL (cond ;(ccb (wt-env var-loc)) - ((var-ref-ccb var) (wt-env var-loc)) - (t (wt-lex var-loc)))) + (CLOSURE (wt-env var-loc)) + (LEXICAL (wt-lex var-loc)) (SPECIAL (wt "(" var-loc "->symbol.dbind)")) (REPLACED (wt var-loc)) (GLOBAL (if *safe-compile* @@ -230,19 +203,19 @@ (defun var-rep-type (var) (case (var-kind var) - ((LEXICAL SPECIAL GLOBAL) :object) + ((LEXICAL CLOSURE SPECIAL GLOBAL) :object) (REPLACED (loc-representation-type (var-loc var))) (t (var-kind var)))) (defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb (if (var-p var) (case (var-kind var) + (CLOSURE + (wt-nl)(wt-env var-loc)(wt "= ") + (wt-coerce-loc (var-rep-type var) loc) + (wt #\;)) (LEXICAL - (wt-nl) - (if (var-ref-ccb var) - (wt-env var-loc) - (wt-lex var-loc)) - (wt "= ") + (wt-nl)(wt-lex var-loc)(wt "= ") (wt-coerce-loc (var-rep-type var) loc) (wt #\;)) (SPECIAL diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 062977a79..0b4152e23 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -139,20 +139,3 @@ (defun wt-data-end () (princ #\; *compiler-output-data*)) - -(defun wt-data-package-operation (form) - (ecase (car form) - (si::select-package - (let ((output (t1ordinary form))) - (cmp-eval form) - (let ((package-name (string (cadr form)))) - (setq *compiler-package* (si::select-package package-name)) - (setq package-name (package-name *compiler-package*)) - (wt-filtered-data (format nil "#!0 ~s" package-name))) - output)) - ;#+nil(wt-filtered-data (format nil "#!0 ~s" (string package-name))))) - (si::%defpackage - (let ((output (t1ordinary `(eval ',form)))) - (wt-filtered-data (format nil "#!1 ~s" (second form))) - (cmp-eval form) - output)))) diff --git a/src/h/internal.h b/src/h/internal.h index df8b2dd4b..3480ba733 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -145,6 +145,9 @@ extern void cl_write_object(cl_object x); /* read.d */ #define RTABSIZE CHAR_CODE_LIMIT /* read table size */ +extern cl_object ecl_packages_to_be_created; +extern cl_object ecl_package_list; + #ifdef __cplusplus } #endif diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index c244fac16..c4eb693b2 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -9,7 +9,7 @@ ;;;; See file '../Copyright' for full details. ;;;; defines SYS:DEFMACRO*, the defmacro preprocessor -(si::select-package "SYSTEM") +(in-package "SYSTEM") #-ecl-min (defvar *dl*) diff --git a/src/lsp/defpackage.lsp b/src/lsp/defpackage.lsp index de2763aa5..7be9c9432 100644 --- a/src/lsp/defpackage.lsp +++ b/src/lsp/defpackage.lsp @@ -164,7 +164,8 @@ (case num (1 ':EXPORT) (2 ':INTERN))))) - `(si::%defpackage + `(eval-when (eval compile load) + (si::dodefpackage ,name ',nicknames ,(car documentation) @@ -174,10 +175,10 @@ ',exported-symbol-names ',shadowing-imported-from-symbol-names-list ',imported-from-symbol-names-list - ',exported-from-package-names)))) + ',exported-from-package-names))))) -(defun %defpackage (name +(defun dodefpackage (name nicknames documentation use diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 271f8d041..c8922d129 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -8,7 +8,7 @@ ;;;; ;;;; See file '../Copyright' for full details. -(si::select-package "SYSTEM") +(in-package "SYSTEM") (defmacro defun (name vl &body body &aux doc-string) "Syntax: (defun name lambda-list {decl | doc}* {form}*) @@ -329,7 +329,7 @@ SECOND-FORM." `(eval-when (compile) (proclaim ',(car decl-specs))))) (defmacro in-package (name) - `(si::select-package ,(string name))) + `(eval-when (eval compile load) (si::select-package ,(string name)))) ;; FIXME! (defmacro the (type value) diff --git a/src/lsp/export.lsp b/src/lsp/export.lsp index 9d5bb9523..1923d6398 100644 --- a/src/lsp/export.lsp +++ b/src/lsp/export.lsp @@ -9,7 +9,8 @@ ;;;; See file '../Copyright' for full details. ;;;; Exporting external symbols of LISP package -(si::select-package "SI") +(eval-when (eval compile load) + (si::select-package "SI")) ;;; ---------------------------------------------------------------------- ;;; @@ -31,7 +32,8 @@ t) (si::fset 'in-package #'(lambda-block in-package (def env) - `(si::select-package ,(string (second def)))) + `(eval-when (eval compile load) + (si::select-package ,(string (second def))))) t) )