mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-01 15:20:36 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merged in the new compiler structure doubly linked list.

Browse source
This commit is contained in:
jjgarcia 2004-12-16 15:56:54 +00:00
parent 615200a550
commit e4fa9f4e73
19 changed files with 494 additions and 423 deletions
Download patch file Download diff file Expand all files Collapse all files

26
src/CHANGELOG
View file

@ -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 ***

22
src/cmp/cmpbind.lsp
View file

@ -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)

9
src/cmp/cmpblock.lsp
View file

@ -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

33
src/cmp/cmpcall.lsp
View file

@ -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)))

32
src/cmp/cmpdefs.lsp
View file

@ -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 }*

1
src/cmp/cmpenv.lsp
View file

@ -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)

12
src/cmp/cmpeval.lsp
View file

@ -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)

127
src/cmp/cmpflet.lsp
View file

@ -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)

2
src/cmp/cmpif.lsp
View file

@ -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

61
src/cmp/cmpinline.lsp
View file

@ -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))

67
src/cmp/cmplam.lsp
View file

@ -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)

116
src/cmp/cmplet.lsp
View file

@ -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)))

32
src/cmp/cmpmac.lsp
View file

@ -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 "#<form ~A ~X>" (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))
(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)))

19
src/cmp/cmpmulti.lsp
View file

@ -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 = <computed value>;
;; 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))

46
src/cmp/cmpspecial.lsp
View file

@ -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

8
src/cmp/cmptag.lsp
View file

@ -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

75
src/cmp/cmptop.lsp
View file

@ -276,18 +276,56 @@
(push new *global-funs*)
(make-c1form* 'DEFUN :args new no-entry))
(defun print-function (x)
(format t "~%<a FUN: ~A, CLOSURE: ~A, LEVEL: ~A, ENV: ~A>"
(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 ");")

11
src/cmp/cmputil.lsp
View file

@ -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

218
src/cmp/cmpvar.lsp
View file

@ -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