diff --git a/src/CHANGELOG b/src/CHANGELOG index ee8544ad1..c69932773 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -28,6 +28,19 @@ ECL 1.0 - ECL now checks whether the lambda list of a DEFMETHOD is compatible in length with a previously specified one. +* Internals: + + - The compiler now uses a more detailed tree to represent the code, keeping + track of where variables are referenced and changed, and which are the + parent forms of a given one. + + - The compiler structures now print unreadably to simplify inspection. + + - New algorithm for computing whether a function has to have a lexical + environment, a full environment or none. + + - Do not replace LET/LET* variables whose value has side effects. + * ANSI compliance: - The value of *READTABLE* can now be modified by the user. @@ -37,6 +50,19 @@ ECL 1.0 - Floats are properly read even when *read-base* is not 10. + - Support for binary streams of arbitrary byte size. By default, streams are + now of type CHARACTER which is equivalent to (UNSIGNED-BYTE 8). Streams of + other types, such as UNSIGNED-BYTE, (UNSIGNED-BYTE 100), (SIGNED-BYTE 2), + etc, are also supported, but the size of the byte is (as of now) rounded up + to a multiple of 8 and READ/WRITE-CHAR signal an error when applied on + these streams. + + - Fixed the order of evaluation of arguments in INCF,DECF,etc (M.Goffioul). + + - Default methods for CLOS streams signal now a type error, which is the + expected error when an object which is not of type stream is passed to the + functions dealing with streams. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index 55413821d..abe3ee344 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -43,7 +43,7 @@ (wt-coerce-loc :object loc) (wt ";")) (wt-comment (var-name var))) - (SPECIAL + ((SPECIAL GLOBAL) (bds-bind loc var)) (t (cond ((not (eq (var-loc var) 'OBJECT)) @@ -61,8 +61,9 @@ ))) ;;; Used by let*, defmacro and lambda's &aux, &optional, &rest, &keyword -(defun bind-init (var form) - (let ((*destination* `(BIND ,var))) +(defun bind-init (form var) + (let ((*destination* `(BIND ,var)) + (bds nil)) ;; assigning location must be done before calling c2expr*, ;; otherwise the increment to *env* or *lex* is done during ;; unwind-exit and will be shadowed by functions (like c2let) @@ -74,11 +75,10 @@ (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))) + ((SPECIAL GLOBAL) + (setf bds t))) (c2expr* form) - (when (eq (var-kind var) 'SPECIAL) + (when bds ;; now the binding is in effect (push 'BDS-BIND *unwind-exit*)))) @@ -92,13 +92,7 @@ (wt-nl "bds_bind(" (var-loc var) ",") (wt-coerce-loc :object loc) (wt ");"))) - ;; 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-bds-bound to record this fact. - (unless (var-bds-bound var) - (push 'BDS-BIND *unwind-exit*) - (setf (var-bds-bound var) t)) + (push 'BDS-BIND *unwind-exit*) (wt-comment (var-name var))) (put-sysprop 'BIND 'SET-LOC 'bind) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index b7d09c3bc..2b4e6a760 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -105,12 +105,9 @@ (incf (var-ref var)))) (incf (blk-ref blk)) (setf (blk-type blk) (type-or (blk-type blk) (c1form-primary-type val))) - (return (make-c1form* 'RETURN-FROM - :local-referred (list var) - ;;:referred-tags (list blk) - :referred-vars (list var) - :type 'T - :args blk type val)))))))) + (return (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/cmpcall.lsp b/src/cmp/cmpcall.lsp index a225b318f..b903ff0d6 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -255,7 +255,7 @@ (c1form-arg 0 value)) ((and (eq name 'VAR) other-forms-flag - (not (var-changed-in-forms (c1form-arg 0 value) other-forms))) + (not (var-changed-in-form-list (c1form-arg 0 value) other-forms))) (c1form-arg 0 value)) (t (let* ((temp (make-temp-var)) @@ -269,6 +269,10 @@ (defvar *text-for-closure* '("env0" "env1" "env2" "env3" "env4" "env5" "env6" "env7" "env8" "env9")) +(defun env-var-name (n) + (or (nth n *text-for-closure*) + (format nil "env~D" n))) + (defun wt-stack-pointer (narg) (wt "cl_env.stack_top-" narg)) @@ -286,24 +290,21 @@ (baboon "Function without a C name: ~A" (fun-name fun))) (let* ((minarg (fun-minarg fun)) (maxarg (fun-maxarg fun)) - (lex-lvl (fun-level fun)) (fun-c-name (fun-cfun fun)) (fun-lisp-name (fun-name fun)) (narg (length args))) - (when (eq (fun-closure fun) 'CLOSURE) - (let ((x (nth *env-lvl* *text-for-closure*))) - (unless x - (setf x (format nil "env~d" n) - (nth n *text-for-closurel*) x)) - (push x args))) - (when (plusp lex-lvl) - (dotimes (n lex-lvl) - (let* ((j (- lex-lvl n 1)) - (x (nth j *text-for-lexical-level*))) - (unless x - (setf x (format nil "lex~d" j) - (nth n *text-for-lexical-level*) x)) - (push x args)))) + (case (fun-closure fun) + (CLOSURE + (push (environment-accessor fun) args)) + (LEXICAL + (let ((lex-lvl (fun-level fun))) + (dotimes (n lex-lvl) + (let* ((j (- lex-lvl n 1)) + (x (nth j *text-for-lexical-level*))) + (unless x + (setf x (format nil "lex~d" j) + (nth n *text-for-lexical-level*) x)) + (push x args)))))) (unless (<= minarg narg maxarg) (error "Wrong number of arguments for function ~S" (or fun-lisp-name 'ANONYMOUS))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index bd1a471af..65d9f2ab2 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -44,19 +44,28 @@ ;;; During Pass1, T or NIL. ;;; During Pass2, the lex-address for the ;;; block id, or NIL. + read-nodes ;;; Nodes (c1forms) in which the reference occurs ) (deftype OBJECT () `(not (or fixnum character short-float long-float))) -(defstruct (var (:include ref)) +(defstruct (var (:include ref) (:constructor %make-var)) ; name ;;; Variable name. ; (ref 0 :type fixnum) ;;; Number of references to the variable (-1 means IGNORE). ; ref-ccb ;;; Cross closure reference: T or NIL. ; ref-clb ;;; Cross local function reference: T or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs + set-nodes ;;; Nodes in which the variable is modified kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, ;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for ;;; LET variables). + (function *current-function*) + ;;; For local variables, in which function it was created. + ;;; For global variables, it doesn't have a meaning. + (functions-setting nil) + (functions-reading nil) + ;;; Functions in which the variable has been modified or read. (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 @@ -76,7 +85,6 @@ ;;; 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. ) ;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE @@ -122,6 +130,7 @@ ;;; During Pass2, the vs-address for the function ;;; closure, or NIL. ; ref-clb ;;; Unused. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs cfun ;;; The cfun for the function. (level 0) ;;; Level of lexical nesting for a function. (env 0) ;;; Size of env of closure. @@ -136,7 +145,9 @@ ;;; Max. number arguments that the function receives. (parent *current-function*) ;;; Parent function, NIL if global. - (referred-funs nil) ;;; List of local functions called in this one. + (local-vars nil) ;;; List of local variables created here. + (referred-vars nil) ;;; List of external variables referenced here. + (referred-funs nil) ;;; List of external functions called in this one. ;;; We only register direct calls, not calls via object. (child-funs nil) ;;; List of local functions defined here. ) @@ -152,6 +163,7 @@ ;;; During Pass1, T or NIL. ;;; During Pass2, the lex-address for the ;;; block id, or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs exit ;;; Where to return. A label. destination ;;; Where the value of the block to go. var ;;; Variable containing the block ID. @@ -165,6 +177,7 @@ ;;; During Pass1, T or NIL. ; ref-clb ;;; Cross local function reference. ;;; During Pass1, T or NIL. +; read-nodes ;;; Nodes (c1forms) in which the reference occurs label ;;; Where to jump: a label. unwind-exit ;;; Where to unwind-no-exit. var ;;; Variable containing frame ID. @@ -173,20 +186,10 @@ (defstruct (info) (local-vars nil) ;;; List of var-objects created directly in the form. - (changed-vars nil) ;;; List of external var-objects changed by the form. - (referred-vars nil) ;;; List of extenal var-objects referred in the form. (type t) ;;; Type of the form. (sp-change nil) ;;; Whether execution of the form may change ;;; the value of a special variable. (volatile nil) ;;; whether there is a possible setjmp. Beppe -; (referred-tags nil) ;;; Tags or block names referenced in the body. - (local-referred nil) ;;; directly referenced in the body: -;;; each reference operator (c1call-symbol, c1go, c1return-from, c1vref -;;; and c1setq1) adds the reference to the info-local-referred of the form -;;; they appear in. -;;; This information is not propagated to an enclosing function (see -;;; add-info) so that we can determine exactly which frame is used -;;; in the body of a function. ) ;;; @@ -369,7 +372,8 @@ The default value is NIL.") ; with fixed number of arguments. ; watch out for multiple values. -(defvar *global-vars* nil) +(defvar *global-var-objects* nil) ; var objects for global/special vars +(defvar *global-vars* nil) ; variables declared special (defvar *global-funs* nil) ; holds { fun }* (defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }* (defvar *local-funs* nil) ; holds { fun }* diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index dc00d81d1..492231be2 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -26,6 +26,7 @@ (setq *objects* nil) (setq *keywords* nil) (setq *local-funs* nil) + (setq *global-var-objects* nil) (setq *global-funs* nil) (setq *linking-calls* nil) (setq *global-entries* nil) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index eaad79f79..0fbe96dba 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -85,9 +85,6 @@ (when fun (let* ((forms (c1args* args)) (lambda-form (fun-lambda fun)) - (referred-vars (and lambda-form (c1form-referred-vars lambda-form))) - (changed-vars (and lambda-form (c1form-changed-vars lambda-form))) - (function-variable (fun-var fun)) (return-type (or (get-local-return-type fun) 'T)) (arg-types (get-local-arg-types fun))) ;; Add type information to the arguments. @@ -101,14 +98,7 @@ (pop arg-types) (pop args)))) (setq forms (nreverse fl)))) - (make-c1form* 'CALL-LOCAL - :sp-change t - :referred-vars (if function-variable - (cons function-variable referred-vars) - referred-vars) - :changed-vars changed-vars - :local-referred (list function-variable) - :type return-type + (make-c1form* 'CALL-LOCAL :sp-change t :type return-type :args fun forms))))) (defun c1call-global (fname args) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 676fb07d3..1d6798d9a 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -18,8 +18,7 @@ (defun c1labels/flet (origin args) (check-args-number origin args 1) - (let ((*funs* *funs*) - (old-funs *funs*) + (let ((new-funs *funs*) (defs '()) (local-funs '()) (fnames '()) @@ -36,28 +35,39 @@ (cmpck (member (car def) fnames) "The function ~s was already defined." (car def)) (push (car def) fnames) - (let ((fun (make-fun :name (car def)))) - (push fun *funs*) + (let* ((name (car def)) + (var (make-var :name name :kind :object)) + (fun (make-fun :name name :var var))) + (push fun new-funs) (push (cons fun (cdr def)) defs))) - ;; Now we can compile the body and the function themselves. Notice - ;; that, whe compiling FLET, we must empty *fun* so that the functions - ;; do not see each other. + ;; Now we compile the functions, either in an empty environment + ;; in which there are no new functions + (let ((*funs* (if (eq origin 'FLET) *funs* new-funs))) + (dolist (def (nreverse defs)) + (let ((fun (first def))) + ;; The closure type will be fixed later on by COMPUTE-... + (push (c1compile-function (rest def) :fun fun :CB/LB 'LB) + local-funs)))) + + ;; When we are in a LABELs form, we have to propagate the external + ;; variables from one function to the other functions that use it. + (dolist (f1 local-funs) + (let ((vars (fun-referred-vars f1))) + (dolist (f2 local-funs) + (when (and (not (eq f1 f2)) + (member f1 (fun-referred-funs f2))) + (add-referred-variables-to-function f2 vars))))) + + ;; Now we can compile the body itself. (multiple-value-bind (body ss ts is other-decl) (c1body (rest args) t) - (let ((*vars* *vars*)) + (let ((*vars* *vars*) + (*funs* new-funs)) (c1add-globals ss) (check-vdecl nil ts is) (setq body-c1form (c1decl-body other-decl body)))) - (when (eq origin 'FLET) - (setf *funs* old-funs)) - (dolist (def (nreverse defs)) - (let ((fun (first def))) - (push (c1compile-function (rest def) :fun fun - :CB/LB (if (fun-ref-ccb fun) 'CB 'LB)) - local-funs))) - ;; Keep only functions that have been referenced at least once. ;; It is not possible to look at FUN-REF before because functions ;; in a LABELS can reference each other. @@ -65,7 +75,6 @@ (if local-funs (make-c1form* 'LOCALS :type (c1form-type body-c1form) - :local-vars (remove nil (mapcar #'fun-var local-funs)) :args local-funs body-c1form (eq origin 'LABELS)) body-c1form))) @@ -77,23 +86,28 @@ (labels ((closure-type (fun &aux (lambda-form (fun-lambda fun))) (let ((vars (fun-referred-local-vars fun)) - (funs (remove fun (fun-referred-funs fun) :test #'child-p))) + (funs (remove fun (fun-referred-funs fun) :test #'child-p)) + (closure nil)) ;; it will have a full closure if it refers external non-global variables - (unless (or vars funs) - (return-from closure-type nil)) (dolist (var vars) ;; ...across CB - (when (ref-ref-ccb var) - (return-from closure-type 'CLOSURE))) - ;; ...or the function itself is referred across CB - (when (fun-ref-ccb fun) - (return-from closure-type 'CLOSURE)) - ;; or if it directly calls a function - (dolist (f funs 'LEXICAL) + (if (ref-ref-ccb var) + (setf closure 'CLOSURE) + (unless closure (setf closure 'LEXICAL)))) + ;; ...or if it directly calls a function + (dolist (f funs) ;; .. which has a full closure - (when (and (not (child-p f fun)) - (eq (fun-closure fun) 'CLOSURE)) - (return 'CLOSURE))))) + (when (not (child-p f fun)) + (case (fun-closure fun) + (CLOSURE (setf closure 'CLOSURE)) + (LEXICAL (unless closure (setf closure 'LEXICAL)))))) + ;; ...or the function itself is referred across CB + (when closure + (when (or (fun-ref-ccb fun) + (and (fun-var fun) + (plusp (var-ref (fun-var fun))))) + (setf closure 'CLOSURE))) + closure)) (child-p (presumed-parent fun) (let ((real-parent (fun-parent fun))) (when real-parent @@ -103,6 +117,9 @@ ;; do not change. (let ((new-type (closure-type fun)) (old-type (fun-closure fun))) +;; (format t "~%CLOSURE-TYPE: ~A ~A -> ~A, ~A" (fun-name fun) +;; old-type new-type (fun-parent fun)) +;; (print (fun-referred-vars fun)) ;; Same type (when (eq new-type old-type) (return-from compute-fun-closure-type nil)) @@ -118,23 +135,29 @@ (setf (var-ref-clb var) nil (var-ref-ccb var) t (var-kind var) 'CLOSURE - (var-loc var) 'OBJECT))) + (var-loc var) 'OBJECT)) + (dolist (f (fun-referred-funs fun)) + (setf (fun-ref-ccb f) t))) ;; If the status of some of the children changes, we have ;; to recompute the closure type. - (when (some #'compute-fun-closure-type (fun-child-funs fun)) - (compute-fun-closure-type f)) + (do ((finish nil t) + (recompute nil)) + (finish + (when recompute (compute-fun-closure-type fun))) + (dolist (f (fun-child-funs fun)) + (when (compute-fun-closure-type f) + (setf recompute t finish nil)))) t))) (defun c2locals (funs body labels ;; labels is T when deriving from labels &aux block-p - (level *level*) (*env* *env*) (*env-lvl* *env-lvl*) env-grows) ;; create location for each function which is returned, ;; either in lexical: (dolist (fun funs) (let* ((var (fun-var fun))) - (when (and var (plusp (var-ref var))) ; the function is returned + (when (plusp (var-ref var)) ; the function is returned (unless (member (var-kind var) '(LEXICAL CLOSURE)) (setf (var-loc var) (next-lcl)) (unless block-p @@ -152,27 +175,15 @@ ;; - first create binding (because of possible circularities) (dolist (fun funs) (let* ((var (fun-var fun))) - (when (and var (plusp (var-ref var))) - (when labels - (incf (fun-env fun))) ; var is included in the closure env + (when (plusp (var-ref var)) (bind nil var)))) + ;; create the functions: + (mapc #'new-local funs) ;; - then assign to it (dolist (fun funs) (let* ((var (fun-var fun))) - (when (and var (plusp (var-ref var))) + (when (plusp (var-ref var)) (set-var (list 'MAKE-CCLOSURE fun) var)))) - ;; We need to introduce a new lex vector when lexical variables - ;; are present in body and it is the outermost FLET or LABELS - ;; (nested FLETS/LABELS can use a single lex). - (when (plusp *lex*) - (incf level)) - ;; create the functions: - (dolist (fun funs) - (let* ((previous (new-local level fun))) - (when previous - (format t "~%> ~A" previous) - (setf (fun-level fun) (fun-level previous) - (fun-env fun) (fun-env previous))))) (c2expr body) (when block-p (wt-nl "}"))) @@ -219,14 +230,14 @@ (setf (fun-ref-ccb fun) t) (push fun (fun-referred-funs *current-function*))) ;; we introduce a variable to hold the funob - (let ((var (or (fun-var fun) - (setf (fun-var fun) - (make-var :name fname :kind :OBJECT))))) - (cond (ccb (setf (var-ref-ccb var) t - (var-kind var) 'CLOSURE) + (let ((var (fun-var fun))) + (cond (ccb (when build-object + (setf (var-ref-ccb var) t + (var-kind var) 'CLOSURE)) (setf (fun-ref-ccb fun) t)) - (clb (setf (var-ref-clb var) t - (var-kind var) 'LEXICAL)))) + (clb (when build-object + (setf (var-ref-clb var) t + (var-kind var) 'LEXICAL))))) (return fun))))) (defun sch-local-fun (fname) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index ef32ced95..8b4dcf10b 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -90,7 +90,7 @@ (let* ((exit *exit*) (*unwind-exit* (cons Tlabel *unwind-exit*)) (*exit* Tlabel)) - (CJF fmla Tlabel exit)) + (CJF fmla Tlabel exit)) (wt-label Tlabel) (c2expr form1)) (t diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 10f2d4244..aaf00c0be 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -12,63 +12,6 @@ (in-package "COMPILER") -;;; Pass 1 generates the internal form -;;; ( id info-object . rest ) -;;; for each form encountered. - -#| -;;; Use a structure of type vector to avoid creating -;;; normal structures before booting CLOS: -(defstruct (info (:type vector) :named) - (changed-vars nil) ;;; List of var-objects changed by the form. - (referred-vars nil) ;;; List of var-objects referred in the form. - (type t) ;;; Type of the form. - (sp-change nil) ;;; Whether execution of the form may change - ;;; the value of a special variable. - (volatile nil) ;;; whether there is a possible setjmp. Beppe - (local-referred nil) ;;; directly referenced in the body. - ) |# - -(defun add-info (to-info from-info &optional boundary) - (setf (info-changed-vars to-info) - (set-difference (union (info-changed-vars from-info) - (info-changed-vars to-info)) - (info-local-vars to-info))) - (setf (info-referred-vars to-info) - (set-difference (union (info-referred-vars from-info) - (info-referred-vars to-info)) - (info-local-vars to-info))) - (when (info-sp-change from-info) - (setf (info-sp-change to-info) t)) -; (setf (info-referred-tags to-info) -; (union (info-referred-tags from-info) -; (info-referred-tags to-info))) - (unless boundary - (setf (info-local-referred to-info) - (union (info-local-referred from-info) - (info-local-referred to-info)))) - ) - -(defun var-changed-in-forms (var forms) - (declare (type var var)) - (let ((kind (var-kind var))) - (if (eq kind 'REPLACED) - (let ((loc (var-loc var))) - (when (var-p loc) - (var-changed-in-forms loc forms))) - (let ((check-specials (or (eq kind 'SPECIAL) (eq kind 'GLOBAL))) - (check-lexical (or (eq kind 'LEXICAL) (eq kind 'CLOSURE)))) - (dolist (form forms) - (when (or (member var (c1form-changed-vars form)) - (and check-specials (c1form-sp-change form)) - ;; They can be modified when a local function is called - ;; FIXME! We need to add a flag to the functions telling - ;; which variables they modify! - (and check-lexical - (member (c1form-name form) - '(CALL-LOCAL MULTIPLE-VALUE-CALL)))) - (return t))))))) - ;;; Valid property names for open coded functions are: ;;; :INLINE-ALWAYS ;;; :INLINE-SAFE safe-compile only @@ -112,7 +55,7 @@ (push (list (c1form-primary-type form) (c1form-arg 0 form)) locs)) (VAR (let ((var (c1form-arg 0 form))) - (if (var-changed-in-forms var (cdr forms)) + (if (var-changed-in-form-list var (cdr forms)) (let* ((var-rep-type (var-rep-type var)) (lcl (make-lcl-var :rep-type var-rep-type :type (var-type var)))) (wt-nl "{" (rep-type-name var-rep-type) " " lcl "= " var ";") @@ -320,7 +263,7 @@ (case (c1form-name form) (LOCATION) (VAR - (when (var-changed-in-forms (c1form-arg 0 form) (cdr forms)) + (when (var-changed-in-form-list (c1form-arg 0 form) (cdr forms)) (setq res t))) (CALL-GLOBAL (let ((fname (c1form-arg 0 form)) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 02ae3a55f..52f8b2ccb 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -59,6 +59,12 @@ (or (eq (fun-closure fun) 'CLOSURE) (/= (fun-minarg fun) (fun-maxarg fun)))) +(defun add-referred-variables-to-function (fun var-list) + (setf (fun-referred-vars fun) + (set-difference (union (fun-referred-vars fun) var-list) + (fun-local-vars fun))) + fun) + (defun c1compile-function (lambda-list-and-body &key (fun (make-fun)) (name (fun-name fun)) global (CB/LB 'CB)) (setf (fun-name fun) name @@ -73,6 +79,7 @@ (setjmps *setjmps*) (lambda-expr (c1lambda-expr lambda-list-and-body (si::function-block-name name))) + (children (fun-child-funs fun)) cfun exported minarg maxarg) (unless (eql setjmps *setjmps*) (setf (c1form-volatile lambda-expr) t)) @@ -96,28 +103,26 @@ (fun-closure fun) nil (fun-minarg fun) minarg (fun-maxarg fun) maxarg - (fun-description fun) name - ) - (loop - (unless (some #'compute-fun-closure-type (fun-child-funs fun)) - (return))) - (unless (fun-parent fun) - (compute-fun-closure-type fun) - (when (and global (fun-closure fun)) - (cmperr "Function ~A is global but is closed over some variables.~%~ -~{~A~}" - (fun-name fun) (mapcar #'var-name (c1form-referred-vars (fun-lambda fun)))))) - ) + (fun-description fun) name) + (reduce #'add-referred-variables-to-function + (mapcar #'fun-referred-vars children) + :initial-value fun) + (reduce #'add-referred-variables-to-function + (mapcar #'fun-referred-vars (fun-referred-funs fun)) + :initial-value fun) + (do ((finish nil)) + (finish) + (setf finish t) + (dolist (f (fun-child-funs fun)) + (when (compute-fun-closure-type f) + (setf finish nil)))) + (compute-fun-closure-type fun) + (when (and global (fun-closure fun)) + (error "Function ~A is global but is closed over some variables.~%~ +~{~A ~}" + (fun-name fun) (mapcar #'var-name (fun-referred-vars fun))))) fun) -(defun fun-referred-vars (fun &key global) - (let ((lambda-form (fun-lambda fun))) - (when lambda-form - (let ((vars (c1form-referred-vars lambda-form))) - (if global - vars - (remove 'GLOBAL vars :key #'var-kind)))))) - (defun c1lambda-expr (lambda-expr &optional (block-name nil block-it) &aux doc body ss is ts @@ -144,7 +149,7 @@ ((endp specs)) (let* ((var (first specs))) (push-vars (setf (first specs) (c1make-var var ss is ts))))) - + (do ((specs (setq optionals (cdr optionals)) (cdddr specs))) ((endp specs)) (let* ((var (c1make-var (first specs) ss is ts)) @@ -334,9 +339,10 @@ (when optionals ;; When binding optional values, we use two calls to BIND. This means ;; 'BDS-BIND is pushed twice on *unwind-exit*, which results in two calls - ;; to bds_unwind1(), which is wrong. A possible fix is to save *unwind-exit* - (let ((*unwind-exit* *unwind-exit*) - (va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG))) + ;; to bds_unwind1(), which is wrong. A simple fix is to save *unwind-exit* + ;; which is what we do here. + (let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG)) + (*unwind-exit* *unwind-exit*)) (do ((opt optionals (cdddr opt))) ((endp opt)) (push (next-label) labels) @@ -348,13 +354,13 @@ (let ((label (next-label))) (wt-nl) (wt-go label) (setq labels (nreverse labels)) - ;;; Bind unspecified optional parameters. + ;; Bind unspecified optional parameters. (do ((opt optionals (cdddr opt))) ((endp opt)) - (wt-label (first labels)) - (pop labels) - (bind-init (first opt) (second opt)) - (when (third opt) (bind nil (third opt)))) + (wt-label (first labels)) + (pop labels) + (bind-init (second opt) (first opt)) + (when (third opt) (bind nil (third opt)))) (wt-label label)) ) @@ -399,7 +405,8 @@ ;; with initform (setf (second KEYVARS[i]) (+ nkey i)) (wt-nl "if(") (wt-loc KEYVARS[i]) (wt "==Cnil){") - (bind-init var init) + (let ((*unwind-exit* *unwind-exit*)) + (bind-init init var)) (wt-nl "}else{") (setf (second KEYVARS[i]) i) (bind KEYVARS[i] var) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 6494a2d8d..56aa08f21 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -73,8 +73,11 @@ :unsafe "In LET body")) (form-type (c1form-primary-type form))) (declare (type var var)) - ;; Automatic treatement for READ-ONLY variables: - (unless (var-changed-in-forms var (list body)) + ;; Automatic treatement for READ-ONLY variables which are not + ;; closed over in other functions. + (unless (or (var-changed-in-form-list var (list body)) + (var-functions-reading var) + (var-functions-setting var)) (setf (var-type var) form-type) (update-var-type var form-type body) ;; * (let ((v2 e2)) e3 e4) => (let () e3 e4) @@ -84,6 +87,7 @@ (when (and (= 0 (var-ref var)) (not (member (var-kind var) '(special global))) (not (form-causes-side-effect form))) + (cmpnote "Removing unused variable ~A" (var-name var)) (go continue)) ;; (let ((v1 e1) (v2 e2) (v3 e3)) (expr e4 v2 e5)) ;; can become @@ -94,17 +98,15 @@ ;; - e2 does not affect v1 nor e3, e3 does not affect e2 ;; - e4 does not affect e2 (when (and (= 1 (var-ref var)) - (member-var var (c1form-referred-vars body)) + (var-referenced-in-form var body) (not (form-causes-side-effect form)) ;; it does not refer to special variables which ;; are changed in the LET form - (dolist (v all-vars t) - (when (member-var v (c1form-referred-vars form)) - (return nil))) + (notany #'(lambda (v) (var-referenced-in-form v form)) all-vars) (catch var (replaceable var body))) - (unless (nsubst-var var form body) - (baboon)) + (cmpnote "Replacing variable ~A by its value ~A" (var-name var) form) + (nsubst-var var form) (go continue)) ) #+nil @@ -191,7 +193,7 @@ (push (cons var (c1form-arg 0 form)) bindings))) (VAR (let* ((var1 (c1form-arg 0 form))) - (cond ((or (var-changed-in-forms var1 (cdr fl)) + (cond ((or (var-changed-in-form-list var1 (cdr fl)) (and (member (var-kind var1) '(SPECIAL GLOBAL)) (member (var-name var1) prev-ss))) (do-init var form fl)) @@ -200,7 +202,7 @@ ;; 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)))) + (not (var-changed-in-form var1 body))) (setf (var-kind var) 'REPLACED (var-loc var) var1)) (t (push (cons var var1) bindings))))) @@ -294,7 +296,9 @@ (form-type (c1form-primary-type form)) (rest-forms (cons body (rest fs)))) ;; Automatic treatement for READ-ONLY variables: - (unless (var-changed-in-forms var rest-forms) + (unless (or (var-changed-in-form-list var rest-forms) + (var-functions-reading var) + (var-functions-setting var)) (setf (var-type var) form-type) (update-var-type var form-type rest-forms) ;; * (let* ((v2 e2)) e3 e4) => (let () e3 e4) @@ -304,6 +308,7 @@ (when (and (= 0 (var-ref var)) (not (member (var-kind var) '(SPECIAL GLOBAL))) (not (form-causes-side-effect form))) + (cmpnote "Removing unused variable ~A" (var-name var)) (go continue)) ;; (let* ((v1 e1) (v2 e2) (v3 e3)) (expr e4 v2 e5)) ;; can become @@ -314,25 +319,25 @@ ;; - e2 does not affect v1 nor e3, e3 does not affect e2 ;; - e4 does not affect e2 (when (and (= 1 (var-ref var)) + (var-referenced-in-form var body) (not (form-causes-side-effect form)) - (member-var var (c1form-referred-vars body)) ;; it does not refer to special variables which ;; are changed in later assignments - (dolist (v (rest vs) t) - (when (member-var v (c1form-referred-vars form)) - (return nil))) + (notany #'(lambda (v) + (var-referenced-in-form v form)) + (rest vs)) (or (and (null (rest vs)) ; last variable ;; its form does not affect previous variables (let ((tforms (list form))) (dolist (v vars) (when (eq v var) (return t)) - (when (var-changed-in-forms v tforms) + (when (var-changed-in-form-list v tforms) (return nil))))) (not (args-cause-side-effect fs))) (catch var (replaceable var body))) - (unless (nsubst-var var form body) - (baboon)) + (cmpnote "Replacing variable ~A by its value ~a" (var-name var) form) + (nsubst-var var form) (go continue)) ) #+nil @@ -381,6 +386,7 @@ (case (c1form-name form) (LOCATION (when (can-be-replaced* var body (cdr fl)) + (cmpnote "Replacing variable ~a by its value" (var-name var)) (setf (var-kind var) 'REPLACED (var-loc var) (c1form-arg 0 form)))) (VAR @@ -391,8 +397,9 @@ ;; 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)))) + (not (var-changed-in-form-list var1 (rest fl))) + (not (var-changed-in-form var1 body))) + (cmpnote "Replacing variable ~a by its value" (var-name var)) (setf (var-kind var) 'REPLACED (var-loc var) var1))))) (unless env-grows @@ -423,7 +430,7 @@ (case (c1form-name form) (LOCATION (bind (c1form-arg 0 form) var)) (VAR (bind (c1form-arg 0 form) var)) - (t (bind-init var form)))) + (t (bind-init form var)))) (t ; local var (let ((*destination* var)) ; nil (ccb) (c2expr* form))) @@ -452,53 +459,36 @@ (defun can-be-replaced (var body) (declare (type var var)) (and (eq (var-kind var) :OBJECT) - (not (member var (c1form-changed-vars body))))) -#| (and (or (eq (var-kind var) 'LEXICAL) - (and (eq (var-kind var) :OBJECT) - (< (var-ref var) *register-min*))) - (not (var-ref-ccb var)) - (not (member var (c1form-changed-vars body)))) -|# + (not (var-changed-in-form var body)))) (defun can-be-replaced* (var body forms) (declare (type var var)) (and (can-be-replaced var body) - (dolist (form forms t) - (when (member var (c1form-changed-vars form)) - (return nil))))) + (not (var-changed-in-form-list var forms)))) -(defun nsubst-var (var form where) - (cond ((null where) - nil) - ((c1form-p where) - (cond ((not (member var (c1form-referred-vars where))) - nil) - ((and (eql (c1form-name where) 'VAR) - (eql (c1form-arg 0 where) var)) - (setf (c1form-changed-vars where) (c1form-changed-vars form) - (c1form-referred-vars where) (c1form-referred-vars form) - (c1form-type where) (c1form-type form) - (c1form-sp-change where) (c1form-sp-change form) - (c1form-volatile where) (c1form-volatile form) - (c1form-local-referred where) (c1form-local-referred form) - (c1form-name where) (c1form-name form) - (c1form-args where) (c1form-args form)) - t) - ((nsubst-var var form (c1form-args where)) - (c1form-add-info1 where form) - (setf (c1form-referred-vars where) - (delete var (c1form-referred-vars where)) - (c1form-local-referred where) - (delete var (c1form-local-referred where))) - t))) - ((atom where) - nil) - (t - (let ((output NIL)) - (dolist (subform where) - (when (nsubst-var var form subform) - (setf output T))) - output)))) +(defun nsubst-var (var form) + (when (var-set-nodes var) + (baboon "Cannot replace a variable that is to be changed")) + (when (var-functions-reading var) + (baboon "Cannot replace a variable that is closed over")) + (when (> (length (var-read-nodes var)) 1) + (baboon "Cannot replace a variable that is used more than once")) + ;; FIXME!!!! + ;; Only take the first value out of the form + #+nil + (setf form (make-c1form* 'VALUES :args (list form))) + (dolist (where (var-read-nodes var)) + (cond ((and (eql (c1form-name where) 'VAR) + (eql (c1form-arg 0 where) var)) + (setf (c1form-type where) (c1form-type form) + (c1form-sp-change where) (c1form-sp-change form) + (c1form-volatile where) (c1form-volatile form) + (c1form-name where) (c1form-name form) + (c1form-args where) (c1form-args form)) + (c1form-add-info where (c1form-args where)) + ) + (t + (baboon "VAR-SET-NODES are only C1FORMS of type VAR"))))) (defun member-var (var list) (let ((kind (var-kind var))) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 1718d9ef8..b5af7f350 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -66,23 +66,20 @@ ;; (defstruct (c1form (:include info) + (:print-object print-c1form) (:constructor do-make-c1form)) (name nil) + (parent nil) (args '())) +(defun print-c1form (form stream) + (format stream "#
" (c1form-name form) (ext::pointer form))) + (defun make-c1form (name subform &rest args) (let ((form (do-make-c1form :name name :args args - :changed-vars (info-changed-vars subform) - :referred-vars (info-referred-vars subform) :type (info-type subform) :sp-change (info-sp-change subform) - :volatile (info-volatile subform) - :local-referred (info-local-referred subform)))) - (c1form-add-info form args) - form) - #+nil - (let ((form (do-make-c1form :name name :args args))) - (add-info form info) + :volatile (info-volatile subform)))) (c1form-add-info form args) form)) @@ -108,15 +105,12 @@ (defun c1form-add-info (form dependents) (dolist (subform dependents form) (cond ((c1form-p subform) - (add-info form subform (eql (c1form-name subform) 'FUNCTION))) - ((and (fun-p subform) (fun-lambda subform)) - (add-info form (fun-lambda subform) t)) + (when (info-sp-change subform) + (setf (info-sp-change form) t)) + (setf (c1form-parent subform) form)) ((consp subform) (c1form-add-info form subform))))) -(defun c1form-add-info1 (form subform) - (add-info form subform (eql (c1form-name subform) 'FUNCTION))) - (defun copy-c1form (form) (copy-structure form)) @@ -142,4 +136,10 @@ (setf type subtype))) type)) - \ No newline at end of file +(defun find-node-in-list (home-node list) + (flet ((parent-node-p (node presumed-child) + (loop + (cond ((null presumed-child) (return nil)) + ((eq node presumed-child) (return t)) + (t (setf presumed-child (c1form-parent presumed-child))))))) + (member home-node list :test #'parent-node-p))) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 074438f61..a35551ba9 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -24,7 +24,9 @@ (c1funcall (list* (first args) (rest forms)))) ;; More complicated case. (t (let ((funob (c1expr (first args)))) - (make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args))))))) + ;; FIXME! The type should be more precise + (make-c1form* 'MULTIPLE-VALUE-CALL :type T + :args funob (c1args* (rest args))))))) (defun c2multiple-value-call (funob forms) (let* ((tot (make-lcl-var :rep-type :cl-index)) @@ -97,6 +99,9 @@ ;; For a single form, we must simply ensure that we only take a single ;; value of those that the function may output. ((endp (rest forms)) + ;; ... FIXME! This can be improved! It leads to code like + ;; value0 = ; + ;; T0 = value0; (let ((*destination* 'VALUE0)) (c2expr* (first forms))) (unwind-exit 'VALUE0)) @@ -143,11 +148,8 @@ (t (setq value (c1expr value) vars (mapcar #'c1vref vars)) - (make-c1form* 'MULTIPLE-VALUE-SETQ - :changed-vars vars - :referred-vars vars - :local-referred vars - :args vars value))))) + (add-to-set-nodes-of-var-list + vars (make-c1form* 'MULTIPLE-VALUE-SETQ :args vars value)))))) (defun c1form-values-number (form) (let ((type (c1form-type form))) @@ -205,7 +207,10 @@ ;; ;; Loop for assigning values to variables ;; - (do ((vs vars (rest vs)) + (do (;; We call BIND twice for each variable. Hence, we need to + ;; remove spurious BDS-BIND from the list. See also C2LAMBDA. + (*unwind-exit* *unwind-exit*) + (vs vars (rest vs)) (i min-values (1+ i))) ((or (endp vs) (= i max-values))) (declare (fixnum i)) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 9d25cd7d8..7f560fcc8 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -70,11 +70,9 @@ (cond ((si::valid-function-name-p fun) (let ((funob (local-function-ref fun t))) (if funob - (let* ((vars (list (fun-var funob)))) - (incf (var-ref (fun-var funob))) - (make-c1form* 'VAR :referred-vars vars - :local-referred vars - :args (first vars))) + (let* ((var (fun-var funob))) + (incf (var-ref var)) + (add-to-read-nodes var (make-c1form* 'VAR :args var))) (make-c1form* 'FUNCTION :sp-change (not (and (symbolp fun) (get-sysprop fun 'NO-SP-CHANGE))) @@ -94,18 +92,27 @@ (GLOBAL (unwind-exit (list 'FDEFINITION fun))) (CLOSURE - (new-local 0 fun) ; 0 was *level* + (new-local fun) (unwind-exit `(MAKE-CCLOSURE ,fun))))) ;;; Mechanism for sharing code. -(defun new-local (level fun) +(defun new-local (fun) ;; returns the previous function or NIL. (declare (type fun fun)) + (case (fun-closure fun) + (CLOSURE + (setf (fun-level fun) 0 (fun-env fun) *env*)) + (LEXICAL + (let ((parent (fun-parent fun))) + ;; Only increase the lexical level if there have been some + ;; new variables created. This way, the same lexical environment + ;; can be propagated through nested FLET/LABELS. + (setf (fun-level fun) (if (plusp *lex*) (1+ *level*) *level*) + (fun-env fun) 0))) + (otherwise + (setf (fun-env fun) 0 (fun-level fun) 0))) (let ((previous (dolist (old *local-funs*) - (when (and (= *env* (fun-env old)) - ;; closures must be embedded in env of - ;; same size - (similar (fun-lambda fun) (fun-lambda old))) + (when (similar fun old) (return old))))) (if previous (progn @@ -115,11 +122,7 @@ (setf (fun-cfun fun) (fun-cfun previous) (fun-lambda fun) nil) previous) - (progn - (setf (fun-level fun) (if (fun-ref-ccb fun) 0 level) - (fun-env fun) *env* - *local-funs* (cons fun *local-funs*)) - NIL)))) + (push fun *local-funs*)))) (defun wt-fdefinition (fun-name) (let ((vv (add-object fun-name))) @@ -130,6 +133,13 @@ (wt "(" vv "->symbol.gfdef)") (wt "ecl_fdefinition(" vv ")")))) +(defun environment-accessor (fun) + (let* ((env-var (env-var-name *env-lvl*)) + (expected-env-size (fun-env fun))) + (if (< expected-env-size *env*) + (format nil "nthcdr(~D,~A)" (- *env* expected-env-size) env-var) + env-var))) + (defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) (declare (type fun fun)) (let* ((closure (fun-closure fun)) @@ -137,7 +147,9 @@ (maxarg (fun-maxarg fun)) (narg (if (= minarg maxarg) maxarg nil))) (cond ((eq closure 'CLOSURE) - (wt "cl_make_cclosure_va((void*)" cfun ",env" *env-lvl* ",Cblock)")) + (wt "cl_make_cclosure_va((void*)" cfun "," + (environment-accessor fun) + ",Cblock)")) ((eq closure 'LEXICAL) (baboon)) (narg ; empty environment fixed number of args diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 7d4c96cdc..a4efef2f0 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -200,11 +200,9 @@ (setf (var-kind var) :OBJECT)))) (incf (var-ref var)) (incf (tag-ref tag)) - (return (make-c1form* 'GO - :local-referred (list var) - :referred-vars (list var) - ;; :referred-tags tag - :args tag (or ccb clb unw)))))))) + (return (add-to-read-nodes var (make-c1form* 'GO :args tag + (or ccb clb unw)))) + ))))) (defun c2go (tag nonlocal) (if nonlocal diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index af5b5133f..72519ad36 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -276,18 +276,56 @@ (push new *global-funs*) (make-c1form* 'DEFUN :args new no-entry)) +(defun print-function (x) + (format t "~%" + (fun-name x) (fun-closure x) (fun-level x) (fun-env x))) + (defun similar (x y) - (or (equal x y) - (and (consp x) - (consp y) - (similar (car x) (car y)) - (similar (cdr x) (cdr y))) - (and (var-p x) - (var-p y) - (equalp x y)) - (and (typep x 'VECTOR) - (typep y 'VECTOR) - (every #'similar x y)))) + ;; FIXME! This could be more accurate + (labels ((similar-ref (x y) + (and (equal (ref-ref-ccb x) (ref-ref-ccb y)) + (equal (ref-ref-clb x) (ref-ref-clb y)) + (equal (ref-ref x) (ref-ref y)))) + (similar-var (x y) + (and (similar-ref x y) + (equal (var-name x) (var-name y)) + (equal (var-kind x) (var-kind y)) + (equal (var-loc x) (var-loc y)) + (equal (var-type x) (var-type y)) + (equal (var-index x) (var-index y)))) + (similar-c1form (x y) + (and (equal (c1form-name x) (c1form-name y)) + (similar (c1form-args x) (c1form-args y)) + (similar (c1form-local-vars x) (c1form-local-vars y)) + (eql (c1form-sp-change x) (c1form-sp-change y)) + (eql (c1form-volatile x) (c1form-volatile y)))) + (similar-fun (x y) + (and (similar-ref x y) + (eql (fun-global x) (fun-global y)) + (eql (fun-exported x) (fun-exported y)) + (eql (fun-closure x) (fun-closure y)) + (similar (fun-var x) (fun-var y)) + (similar (fun-lambda x) (fun-lambda y)) + (= (fun-level x) (fun-level y)) + (= (fun-env x) (fun-env y)) + (= (fun-minarg x) (fun-minarg y)) + (eql (fun-maxarg x) (fun-maxarg y)) + (similar (fun-local-vars x) (fun-local-vars y)) + (similar (fun-referred-vars x) (fun-referred-vars y)) + (similar (fun-referred-funs x) (fun-referred-funs y)) + (similar (fun-child-funs x) (fun-child-funs y))))) + (and (eql (type-of x) (type-of y)) + (typecase x + (CONS (and (similar (car x) (car y)) + (similar (cdr x) (cdr y)))) + (VAR (similar-var x y)) + (FUN (similar-fun x y)) + (REF (similar-ref x y)) + (TAG NIL) + (BLK NIL) + (C1FORM (similar-c1form x y)) + (SEQUENCE (and (every #'similar x y))) + (T (equal x y)))))) (defun t2defun (fun no-entry) (declare (ignore sp funarg-vars)) @@ -435,8 +473,8 @@ (t1expr `(progn ,@doc))) (setq form (c1expr (second args))) (add-load-time-values) - (make-c1form* 'DEFVAR :args (make-var :name name :kind 'SPECIAL - :loc (add-symbol name)) form)))) + (make-c1form* 'DEFVAR :args (c1make-global-variable name :kind 'SPECIAL) + form)))) (defun t2defvar (var form &aux (vv (var-loc var))) (let* ((*exit* (next-label)) @@ -528,7 +566,9 @@ ) (defun t3local-fun (fun &aux (lambda-expr (fun-lambda fun)) - (level (fun-level fun)) + (level (if (eq (fun-closure fun) 'LEXICAL) + (fun-level fun) + 0)) (cfun (fun-cfun fun)) (minarg (fun-minarg fun)) (maxarg (fun-maxarg fun)) @@ -595,10 +635,13 @@ (not (ref-ref-ccb x)) ;; special variable (eq (var-kind x) 'special) + ;; not actually referenced + (and (not (var-referenced-in-form x (fun-lambda fun))) + (not (var-changed-in-form x (fun-lambda fun)))) ;; parameter of this closure ;; (not yet bound, therefore var-loc is OBJECT) (eq (var-loc x) 'OBJECT))) - (c1form-local-referred lambda-expr)))) + (fun-referred-vars fun)))) (setq clv-used (sort clv-used #'> :key #'var-loc)) (when clv-used (wt-nl "{cl_object scan=env0;") @@ -659,7 +702,7 @@ (maxarg (fun-maxarg fun)) (narg (if (= minarg maxarg) maxarg nil))) ;; FIXME! Look at c2function! - (new-local 0 fun) + (new-local fun) (if macro (if narg (wt-nl "cl_def_c_macro(" fname ",(void*)" cfun "," narg ");") diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 1ca541d33..c9ecfc8f1 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -12,6 +12,17 @@ (in-package "COMPILER") +(defvar *c1form-level* 0) +(defun print-c1forms (form) + (cond ((consp form) + (let ((*c1form-level* (1+ *c1form-level*))) + (mapc #'print-c1forms form))) + ((c1form-p form) + (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form)) + (print-c1forms (c1form-args form)) + form + ))) + (defun print-ref (ref-object stream) (let ((name (ref-name ref-object))) (if name diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 1aa567d7b..707c2baf5 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -12,6 +12,76 @@ (in-package "COMPILER") +(defun make-var (&rest args) + (let ((var (apply #'%make-var args))) + (unless (member (var-kind var) '(SPECIAL GLOBAL)) + (when *current-function* + (push var (fun-local-vars *current-function*)))) + var)) + +(defun var-referenced-in-form-list (var form-list) + (dolist (f form-list nil) + (when (var-referenced-in-form var f) + (return t)))) + +(defun var-changed-in-form-list (var form-list) + (dolist (f form-list nil) + (when (var-changed-in-form var f) + (return t)))) + +;;; FIXME! VAR-REFERENCED-IN-FORM and VAR-CHANGED-IN-FORM are too +;;; pessimistic. One should check whether the functions reading/setting the +;;; variable are actually called from the given node. The problem arises when +;;; we create a closure of a function, as in +;;; +;;; (let* ((a 1) (b #'(lambda () (incf a)))) ...) +;;; +;;; To know whether A is changed or read, we would have to track where B is +;;; actually used. + +(defun var-referenced-in-form (var form) + (declare (type var var)) + (if (eq (var-kind var) 'REPLACED) + (let ((loc (var-loc var))) + (when (var-p loc) + (var-referenced-in-forms loc form))) + (or (find-node-in-list form (var-read-nodes var)) + (var-functions-reading var)))) + +(defun var-changed-in-form (var form) + (declare (type var var)) + (let ((kind (var-kind var))) + (if (eq (var-kind var) 'REPLACED) + (let ((loc (var-loc var))) + (when (var-p loc) + (var-changed-in-form loc form))) + (or (find-node-in-list form (var-set-nodes var)) + (if (or (eq kind 'SPECIAL) (eq kind 'GLOBAL)) + (c1form-sp-change form) + (var-functions-setting var)))))) + +(defun add-to-read-nodes (var form) + (push form (var-read-nodes var)) + (when *current-function* + (unless (eq *current-function* (var-function var)) + (pushnew *current-function* (var-functions-reading var)) + (pushnew var (fun-referred-vars *current-function*)))) + form) + +(defun add-to-set-nodes (var form) + (push form (var-set-nodes var)) + ;;(push form (var-read-nodes var)) + (when *current-function* + (unless (eq *current-function* (var-function var)) + (pushnew *current-function* (var-functions-setting var)) + (pushnew var (fun-referred-vars *current-function*)))) + form) + +(defun add-to-set-nodes-of-var-list (var-list form) + (dolist (v var-list) + (add-to-set-nodes v form)) + form) + ;;; 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 @@ -61,42 +131,24 @@ ;;; not defined. This list is used only to suppress duplicated warnings when ;;; undefined variables are detected. -(defun c1make-var (name specials ignores types &aux x) - (let ((var (make-var :name name))) - (declare (type var var)) ; Beppe - (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) - (cmpck (constantp name) "The constant ~s is being bound." name) - - (cond ((or (member name specials) (sys:specialp name) +(defun c1make-var (name specials ignores types) + (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) + (cmpck (constantp name) "The constant ~s is being bound." name) + (let (type) + (if (setq type (assoc name types)) + (setq type (cdr type)) + (setq type 'T)) + (cond ((or (member name specials) + (sys:specialp name) (check-global name)) ;; added. Beppe 17 Aug 1987 - - (setf (var-kind var) 'SPECIAL) - (setf (var-loc var) (add-symbol name)) - (cond ((setq x (assoc name types)) - (setf (var-type var) (cdr x))) - ((setq x (get-sysprop name 'CMP-TYPE)) - (setf (var-type var) x))) - (setq *special-binding* t)) + (setq *special-binding* t) + (unless type + (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) + (c1make-global-variable name :kind 'SPECIAL :type type)) (t - (dolist (v types) - (when (eq (car v) name) - (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)))) - )) -; (when (or (null (var-type var)) -; (eq t (var-type var))) -; (setf (var-loc var) 'OBJECT)) - ;; :READ-ONLY variable treatment. -; (when (eq 'READ-ONLY (var-type var)) -; (setf (var-type var) 't)) - (setf (var-kind var) 'LEXICAL))) ; we rely on check-vref to fix it - (when (member name ignores) (setf (var-ref var) -1)) ; IGNORE. - var) - ) + (make-var :name name :type type :loc 'OBJECT + :kind 'LEXICAL ; we rely on check-vref to fix it + :ref (if (member name ignores) -1 0)))))) (defun check-vref (var) (when (eq (var-kind var) 'LEXICAL) @@ -115,11 +167,13 @@ (unless (var-p vref) ;; This might be the case if there is a symbol macrolet (return-from c1var vref)) - (make-c1form* 'VAR - :referred-vars (list vref) - :local-referred (list vref) - :type (var-type vref) - :args vref))) + (let ((output (make-c1form* 'VAR :type (var-type vref) + :args vref))) + (add-to-read-nodes vref output) + output) + #+nil + (add-to-read-nodes vref (make-c1form* 'VAR :type (var-type vref) + :args vref)))) (defun make-lcl-var (&key rep-type (type 'T)) (unless rep-type @@ -156,17 +210,8 @@ (var-loc var) 'OBJECT)))) (incf (var-ref var)) (return-from c1vref var)))) ; ccb - (let ((var (sch-global name))) - (unless var - (unless (or (sys:specialp name) (check-global name)) - (undefined-variable name)) - (setq var (make-var :name name - :kind 'GLOBAL - :loc (add-symbol name) - :type (or (get-sysprop name 'CMP-TYPE) t))) - (push var *undefined-vars*)) - var) ; ccb - ) + (c1make-global-variable name :warn t + :type (or (get-sysprop name 'CMP-TYPE) t))) ;;; At each variable binding, the variable is added to *vars* which @@ -193,11 +238,11 @@ (case (var-kind var) (CLOSURE (wt-env var-loc)) (LEXICAL (wt-lex var-loc)) - (SPECIAL (wt "SYM_VAL(" var-loc ")")) (REPLACED (wt var-loc)) - (GLOBAL (if (safe-compile) - (wt "symbol_value(" var-loc ")") - (wt "SYM_VAL(" var-loc ")"))) + ((SPECIAL GLOBAL) + (if (safe-compile) + (wt "symbol_value(" var-loc ")") + (wt "SYM_VAL(" var-loc ")"))) (t (wt var-loc)) )) @@ -218,16 +263,12 @@ (wt-nl)(wt-lex var-loc)(wt "= ") (wt-coerce-loc (var-rep-type var) loc) (wt #\;)) - (SPECIAL - (wt-nl "SYM_VAL(" var-loc ")= ") - (wt-coerce-loc (var-rep-type var) loc) - (wt #\;)) - (GLOBAL + ((SPECIAL GLOBAL) (if (safe-compile) (wt-nl "cl_set(" var-loc ",") - (wt-nl "SYM_VAL(" var-loc ")= ")) + (wt-nl "ECL_SET(" var-loc ",")) (wt-coerce-loc (var-rep-type var) loc) - (wt (if (safe-compile) ");" ";"))) + (wt ");")) (t (wt-nl var-loc "= ") (wt-coerce-loc (var-rep-type var) loc) @@ -245,15 +286,22 @@ ;;; ---------------------------------------------------------------------- +(defun c1make-global-variable (name &key (type t) (kind 'GLOBAL) (warn nil)) + (let ((var (find name *global-var-objects* :key #'var-name))) + (unless var + (setf var (make-var :name name :kind kind :type type :loc (add-symbol name)))) + (push var *global-var-objects*) + (when warn + (unless (or (sys:specialp name) (check-global name)) + (undefined-variable name) + (push var *undefined-vars*))) + var)) + (defun c1add-globals (globals) (dolist (name globals) - (push (make-var :name name - :kind 'GLOBAL - :loc (add-symbol name) - :type (let ((x (get-sysprop name 'CMP-TYPE))) (if x x t)) - ) - *vars*)) - ) + (push (c1make-global-variable name :kind 'GLOBAL + :type (or (get-sysprop name 'CMP-TYPE) 'T)) + *vars*))) (defun c1setq (args) (let ((l (length args))) @@ -285,11 +333,7 @@ (setq type T)) ;; Is this justified???? #+nil(setf (c1form-type form1) type) - (make-c1form* 'SETQ :type type - :changed-vars (list name1) - :referred-vars (list name1) - :local-referred (list name1) - :args name1 form1))) + (add-to-set-nodes name1 (make-c1form* 'SETQ :type type :args name1 form1)))) (defun c2setq (vref form) (let ((*destination* vref)) (c2expr* form)) @@ -356,26 +400,20 @@ (vrefs '()) (forms '())) ((endp l) - (make-c1form* 'PSETQ :type '(MEMBER NIL) :changed-vars vrefs - :args (reverse vrefs) (nreverse forms))) - (let* ((vref (c1vref (first l))) - (form (c1expr (second l))) - (type (type-and (var-type vref) (c1form-primary-type form)))) - (unless type - (cmpwarn "Type mismatch between ~s and ~s." name form) - (setq type T)) + (add-to-set-nodes-of-var-list + vrefs (make-c1form* 'PSETQ :type '(MEMBER NIL) + :args (reverse vrefs) (nreverse forms)))) + (let* ((vref (c1vref (first l))) + (form (c1expr (second l))) + (type (type-and (var-type vref) (c1form-primary-type form)))) + (unless type + (cmpwarn "Type mismatch between ~s and ~s." name form) + (setq type T)) ;; Is this justified???? #+nil(setf (c1form-type form) type) (push vref vrefs) (push form forms)))) -(defun var-referred-in-forms (var forms) - (let ((check-specials (member (var-kind var) '(SPECIAL GLOBAL)))) - (dolist (form forms nil) - (when (or (member var (c1form-referred-vars form)) - (and check-specials (c1form-sp-change form))) - (return-from var-referred-in-forms t))))) - (defun c2psetq (vrefs forms &aux (*lcl* *lcl*) (saves nil) (blocks 0)) ;; similar to inline-args (do ((vrefs vrefs (cdr vrefs)) @@ -384,8 +422,8 @@ ((null vrefs)) (setq var (first vrefs) form (car forms)) - (if (or (var-changed-in-forms var (cdr forms)) - (var-referred-in-forms var (cdr forms))) + (if (or (var-changed-in-form-list var (rest forms)) + (var-referenced-in-form-list var (rest forms))) (case (c1form-name form) (LOCATION (push (cons var (c1form-arg 0 form)) saves)) (otherwise