From f76c1888c63e91c350cf085c9f30698a406edebd Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 4 Jul 2005 09:20:24 +0000 Subject: [PATCH] - The T1 and T3 forms of the compiler have been almost removed. Now, handling of DEFUN as a toplevel form is made via some new declaration C-GLOBAL and some magic both in the optimizer for FSET and in the compiler C1COMPILE-FUNCTION. - CLINES is now handled with a macro and all lines from CLINES are written together in the header. - It is now illegal to have SI::C-LOCAL inside a macro function. --- src/clos/defclass.lsp | 1 - src/cmp/cmpdefs.lsp | 11 ++ src/cmp/cmpenv.lsp | 3 +- src/cmp/cmpeval.lsp | 10 +- src/cmp/cmplam.lsp | 19 ++- src/cmp/cmpspecial.lsp | 11 +- src/cmp/cmptop.lsp | 308 ++++++++++++++++------------------------- src/doc/todo.txt | 42 +++--- src/lsp/evalmacros.lsp | 14 +- src/lsp/loop2.lsp | 2 - 10 files changed, 181 insertions(+), 240 deletions(-) diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index 536463daa..d877a75b9 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -33,7 +33,6 @@ output-list)))) (defmacro defclass (&whole form &rest args) - (declare (si::c-local)) (let* (name superclasses slots options metaclass-name default-initargs documentation (processed-options '()) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 0555b4f25..710e24e15 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -149,6 +149,9 @@ (env 0) ;;; Size of env of closure. (global nil) ;;; Global lisp function. (exported nil) ;;; Its C name can be seen outside the module. + (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no + ;;; function object and the C function is called + ;;; directly closure ;;; During Pass2, T if env is used inside the function var ;;; the variable holding the funob description ;;; Text for the object, in case NAME == NIL. @@ -378,6 +381,14 @@ The default value is NIL.") (defvar *volatile*) (defvar *setjmps* 0) +(defvar *compile-toplevel* T + "Holds NIL or T depending on whether we are compiling a toplevel form.") + +(defvar *clines-string-list* '() + "List of strings containing C/C++ statements which are directly inserted +in the translated C/C++ file. Notice that it is unspecified where these +lines are inserted, but the order is preserved") + (defvar *compile-time-too* nil) (defvar *not-compile-time* nil) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 7d23cd51e..88930463f 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -35,6 +35,7 @@ (setq *reservations* nil) (setq *top-level-forms* nil) (setq *compile-time-too* nil) + (setq *clines-string-list* '()) (setq *function-declarations* nil) (setq *inline-functions* nil) (setq *inline-blocks* 0) @@ -395,7 +396,7 @@ (cmperr "Not a valid function name ~s in declaration ~s" fun decl)))) (DECLARATION (do-declaration (rest decl) #'cmperr)) - (SI::C-LOCAL) + ((SI::C-LOCAL SI::C-GLOBAL)) ((DYNAMIC-EXTENT IGNORABLE) ;; FIXME! SOME ARE IGNORED! ) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 4e99a3946..3d4286898 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -28,9 +28,7 @@ (c1var form))) (t (c1var form)))) ((consp form) - (let ((fun (car form)) - ;; #+cltl2 - setf-symbol) + (let ((fun (car form))) (cond ((symbolp fun) (c1call-symbol fun (cdr form))) ((and (consp fun) (eq (car fun) 'LAMBDA)) @@ -152,9 +150,9 @@ ) (defun c1progn (forms) - (cond ((endp forms) (c1nil)) - ((endp (cdr forms)) (c1expr (car forms))) - (t (let* ((fl (mapcar #'c1expr forms)) + (cond ((endp forms) (t1/c1expr 'NIL)) + ((endp (cdr forms)) (t1/c1expr (car forms))) + (t (let* ((fl (mapcar #'t1/c1expr forms)) (output-form (first (last fl))) (output-type (and output-form (c1form-type output-form)))) (make-c1form* 'PROGN :type output-type :args fl))))) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index cdb5892d7..f4a0f58da 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -66,7 +66,7 @@ fun) (defun c1compile-function (lambda-list-and-body &key (fun (make-fun)) - (name (fun-name fun)) global (CB/LB 'CB)) + (name (fun-name fun)) (CB/LB 'CB)) (setf (fun-name fun) name (fun-parent fun) *current-function*) (when *current-function* @@ -77,9 +77,12 @@ (*blocks* (cons CB/LB *blocks*)) (*tags* (cons CB/LB *tags*)) (setjmps *setjmps*) + (decl (si::process-declarations (rest lambda-list-and-body))) (lambda-expr (c1lambda-expr lambda-list-and-body (si::function-block-name name))) (children (fun-child-funs fun)) + (global (and (assoc 'SI::C-GLOBAL decl) 'T)) + (no-entry (and (assoc 'SI::C-LOCAL decl) 'T)) cfun exported minarg maxarg) (unless (eql setjmps *setjmps*) (setf (c1form-volatile lambda-expr) t)) @@ -87,6 +90,9 @@ (if global (multiple-value-setq (cfun exported) (exported-fname name)) (setf cfun (next-cfun "LC~D~A" name) exported nil)) + #+ecl-min + (when (member name c::*in-all-symbols-functions*) + (setf no-entry t)) (if exported ;; Check whether the function was proclaimed to have a certain ;; number of arguments, and otherwise produce a function with @@ -103,7 +109,8 @@ (fun-closure fun) nil (fun-minarg fun) minarg (fun-maxarg fun) maxarg - (fun-description fun) name) + (fun-description fun) name + (fun-no-entry fun) no-entry) (reduce #'add-referred-variables-to-function (mapcar #'fun-referred-vars children) :initial-value fun) @@ -117,10 +124,12 @@ (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.~%~ + (when global + (when (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-name fun) (mapcar #'var-name (fun-referred-vars fun)))) + (new-defun fun (fun-no-entry fun)))) fun) (defun c1lambda-expr (lambda-expr diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 7f560fcc8..e92311b62 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -17,15 +17,6 @@ (check-args-number 'QUOTE args 1 1) (c1constant-value (car args) t)) -(defun c1eval-when (args) - (check-args-number 'EVAL-WHEN args 1) - (dolist (situation (car args) (c1nil)) - (case situation - ((EVAL :EXECUTE) (return-from c1eval-when (c1progn (cdr args)))) - ((LOAD COMPILE :LOAD-TOPLEVEL :COMPILE-TOPLEVEL)) - (otherwise - (cmperr "The situation ~s is illegal." situation))))) - (defun c1declare (args) (cmperr "The declaration ~s was found in a bad place." (cons 'DECLARE args))) @@ -82,7 +73,7 @@ "The lambda expression ~s is illegal." fun) (let* ((name (and (eq (first fun) 'EXT::LAMBDA-BLOCK) (first (setf fun (rest fun))))) - (fun (c1compile-function (rest fun) :name name :global nil)) + (fun (c1compile-function (rest fun) :name name)) (lambda-form (fun-lambda fun))) (make-c1form 'FUNCTION lambda-form 'CLOSURE lambda-form fun))) (t (cmperr "The function ~s is illegal." fun))))) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 139bbd488..2f7f9355d 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -32,20 +32,29 @@ (member fun *toplevel-forms-to-print*)) (print-current-form)) (cond - ((symbolp fun) - (cond ((setq fd (get-sysprop fun 'T1)) - (funcall fd args)) - ((get-sysprop fun 'C1) (t1ordinary form)) - ((setq fd (macro-function fun)) - (t1expr* (cmp-expand-macro fd fun (cdr form)))) - ((and (setq fd (assoc fun *funs*)) - (eq (second fd) 'MACRO)) - (t1expr* (cmp-expand-macro (third fd) fun (cdr form)))) - (t (t1ordinary form)) - )) ((consp fun) (t1ordinary form)) - (t (cmperr "~s is illegal function." fun))) - )))) + ((not (symbolp fun)) + (cmperr "~s is illegal function." fun)) + ((eq fun 'QUOTE) + (t1ordinary 'NIL)) + ((setq fd (get-sysprop fun 'T1)) + (funcall fd args)) + ((get-sysprop fun 'C1) (t1ordinary form)) + ((setq fd (macro-function fun)) + (t1expr* (cmp-expand-macro fd fun (cdr form)))) + ((and (setq fd (assoc fun *funs*)) + (eq (second fd) 'MACRO)) + (t1expr* (cmp-expand-macro (third fd) fun (cdr form)))) + (t (t1ordinary form)) + ))))) + +(defun t1/c1expr (form) + (cond ((not *compile-toplevel*) + (c1expr form)) + ((atom form) + (t1ordinary form)) + (t + (t1expr* form)))) (defun t2expr (form) (when form @@ -76,15 +85,6 @@ ;; so disassemble can redefine it (t3local-fun (first lfs))))))) -(defun t3expr (form) - (when form - (emit-local-funs) - (let ((def (get-sysprop (c1form-name form) 'T3))) - (when def - ;; new local functions get pushed into *local-funs* - (apply def (c1form-args form)))) - (emit-local-funs))) - (defun ctop-write (name h-pathname data-pathname &key system-p shared-data &aux def top-output-string @@ -93,6 +93,14 @@ ;(let ((*print-level* 3)) (pprint *top-level-forms*)) (setq *top-level-forms* (nreverse *top-level-forms*)) (wt-nl1 "#include \"" (si::coerce-to-filename h-pathname) "\"") + ;; All lines from CLINES statements are grouped at the beginning of the header + ;; Notice that it does not make sense to guarantee that c-lines statements + ;; are produced in-between the function definitions, because two functions + ;; might be collapsed into one, or we might not produce that function at all + ;; and rather inline it. + (do () + ((null *clines-string-list*)) + (wt-h (pop *clines-string-list*))) (wt-h "#ifdef __cplusplus") (wt-h "extern \"C\" {") (wt-h "#endif") @@ -143,7 +151,7 @@ (*env* 0) (*level* 0) (*temp* 0)) (t2expr form)) (let ((*compiler-output1* c-output-file)) - (t3expr form))) + (emit-local-funs))) (wt-function-epilogue) (wt-nl1 "}") (setq top-output-string (get-output-stream-string *compiler-output1*))) @@ -190,77 +198,44 @@ (wt-h "#endif") (wt-nl top-output-string)) -(defun t1eval-when (args &aux (load-flag nil) (compile-flag nil)) +(defun c1eval-when (args) (check-args-number 'EVAL-WHEN args 1) - (dolist (situation (car args)) - (case situation - ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) - ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) - ((EVAL :EXECUTE)) - (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." - situation)))) - (let ((*compile-time-too* compile-flag)) - (cond (load-flag - (t1progn (rest args))) + (let ((load-flag nil) + (compile-flag nil) + (execute-flag nil)) + (dolist (situation (car args)) + (case situation + ((LOAD :LOAD-TOPLEVEL) (setq load-flag t)) + ((COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) + ((EVAL :EXECUTE) + (if *compile-toplevel* + (setq compile-flag (or *compile-time-too* compile-flag)) + (setq execute-flag t))) + (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." + situation)))) + (cond ((not *compile-toplevel*) + (c1progn (and execute-flag (rest args)))) + (load-flag + (let ((*compile-time-too* compile-flag)) + (c1progn (rest args)))) (compile-flag - (cmp-eval (cons 'PROGN (cdr args))) - (make-c1form* 'PROGN :args NIL))))) + (cmp-eval (cons 'PROGN (rest args))) + (c1progn 'NIL)) + (t + (c1progn 'NIL))))) -(defun t1compiler-let (args &aux (symbols nil) (values nil)) - (check-args-number 'COMPILER-LET args 1) - (dolist (spec (car args)) - (cond ((consp spec) - (cmpck (not (and (symbolp (car spec)) - (or (endp (cdr spec)) - (endp (cddr spec))))) - "The variable binding ~s is illegal." spec) - (push (car spec) symbols) - (push (if (endp (cdr spec)) nil (eval (second spec))) values)) - ((symbolp spec) - (push spec symbols) - (push nil values)) - (t (cmperr "The variable binding ~s is illegal." spec)))) - (setq symbols (nreverse symbols)) - (setq values (nreverse values)) - (setq args (progv symbols values (t1progn (cdr args)))) - ) - -(defun t1progn (args) - (make-c1form* 'PROGN :args (mapcar #'t1expr* args))) +(defun t2compiler-let (symbols values body) + (progv symbols values (c2expr body))) (defun t2progn (args) (mapcar #'t2expr args)) -(defun t3progn (args) - (mapcar #'t3expr args)) - (defun exported-fname (name) (let (cname) (if (and (symbolp name) (setf cname (get-sysprop name 'Lfun))) (values cname t) (values (next-cfun "L~D~A" name) nil)))) -(defun t1defun (args) - (check-args-number 'DEFUN args 2) - (when *compile-time-too* (cmp-eval (cons 'DEFUN args))) - (let* ((fname (first args)) - (lambda-list-and-body (rest args)) - (fun (c1compile-function lambda-list-and-body :name fname :global t)) - (no-entry nil) - (doc nil)) - (multiple-value-bind (decl body doc) - (si::process-declarations (rest lambda-list-and-body) t) - (cond ((and *allow-c-local-declaration* (assoc 'si::c-local decl)) - (setq no-entry t)) - #+ecl-min - ((member fname c::*in-all-symbols-functions*) - (setq no-entry t)) - ((setq doc (si::expand-set-documentation fname 'function doc)) - (t1expr `(progn ,@doc))))) - (add-load-time-values) - (setq output (new-defun fun no-entry)) - output)) - ;;; Mechanism for sharing code: ;;; FIXME! Revise this 'DEFUN stuff. (defun new-defun (new &optional no-entry) @@ -276,8 +251,7 @@ (fun-minarg new) (fun-minarg old) (fun-maxarg new) (fun-maxarg old)) (return)))) - (push new *global-funs*) - (make-c1form* 'DEFUN :args new no-entry)) + (push new *global-funs*)) (defun print-function (x) (format t "~%" @@ -330,22 +304,6 @@ (SEQUENCE (and (every #'similar x y))) (T (equal x y)))))) -(defun t2defun (fun no-entry) - (declare (ignore sp funarg-vars)) - ;; If the function is not shared, emit it. - (when (fun-lambda fun) - (push fun *local-funs*)) - (unless no-entry - (let* ((fname (fun-name fun)) - (vv (add-object fname)) - (cfun (fun-cfun fun)) - (minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (narg (if (= minarg maxarg) maxarg nil))) - (if narg - (wt-nl "cl_def_c_function(" vv ",(void*)" cfun "," narg ");") - (wt-nl "cl_def_c_function_va(" vv ",(void*)" cfun ");"))))) - (defun wt-function-prolog (&optional sp local-entry) (wt " VT" *reservation-cmacro* " VLEX" *reservation-cmacro* @@ -429,15 +387,18 @@ (defun t1ordinary (form) (when *compile-time-too* (cmp-eval form)) - (setq form (c1expr form)) - (add-load-time-values) - (make-c1form* 'ORDINARY :args form)) + (let ((*compile-toplevel* nil) + (*compile-time-too* nil)) + (setq form (c1expr form)) + (add-load-time-values) + (make-c1form* 'ORDINARY :args form))) (defun t2ordinary (form) - (let* ((*exit* (next-label)) (*unwind-exit* (list *exit*)) + (let* ((*exit* (next-label)) + (*unwind-exit* (list *exit*)) (*destination* 'TRASH)) - (c2expr form) - (wt-label *exit*))) + (c2expr form) + (wt-label *exit*))) (defun add-load-time-values () (when (listp *load-time-values*) @@ -462,18 +423,6 @@ (c2expr form) (wt-label *exit*))) -(defun t1decl-body (decls body) - (if (null decls) - (t1progn body) - (let* ((*function-declarations* *function-declarations*) - (si:*alien-declarations* si:*alien-declarations*) - (*notinline* *notinline*) - (*safety* *safety*) - (*space* *space*) - (*speed* *speed*) - (dl (c1add-declarations decls))) - (make-c1form* 'DECL-BODY :args dl (t1progn body))))) - (defun t2decl-body (decls body) (let ((*safety* *safety*) (*space* *space*) @@ -482,47 +431,12 @@ (c1add-declarations decls) (t2expr body))) -(defun t3decl-body (decls body) - (let ((*safety* *safety*) - (*space* *space*) - (*speed* *speed*) - (*notinline* *notinline*)) - (c1add-declarations decls) - (t3expr body))) - -(defun t1locally (args) - (multiple-value-bind (body ss ts is other-decl) - (c1body args t) - (c1declare-specials ss) - (check-vdecl nil ts is) - (t1decl-body other-decl body))) - -(defun t1macrolet (args &aux (*funs* *funs*)) - (check-args-number 'MACROLET args 1) - (dolist (def (car args)) - (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) - "The macro definition ~s is illegal." def) - (push (list (car def) - 'MACRO - (si::make-lambda (car def) - (cdr (sys::expand-defmacro (car def) (second def) (cddr def))))) - *funs*)) - (t1locally (cdr args))) - -(defun t1symbol-macrolet (args &aux (*vars* *vars*)) - (check-args-number 'SYMBOL-MACROLET args 1) - (dolist (def (car args)) - (cmpck (or (endp def) (not (symbolp (car def))) (endp (cdr def))) - "The symbol-macro definition ~s is illegal." def) - (push def *vars*)) - (t1locally (cdr args))) - -(defun t1clines (args) +(defmacro ffi:clines (&rest args) (dolist (s args) - (cmpck (not (stringp s)) "The argument to CLINES, ~s, is not a string." s)) - (make-c1form* 'CLINES :args args)) - -(defun t3clines (ss) (dolist (s ss) (wt-nl1 s))) + (unless (stringp s) + (error "The argument to CLINES, ~s, is not a string." s))) + `(eval-when (:compile-toplevel) + (setf *clines-string-list* (nconc *clines-string-list* (copy-list ',args))))) (defun parse-cvspecs (x &aux (cvspecs nil)) (dolist (cvs x (nreverse cvspecs)) @@ -650,31 +564,51 @@ ) ;;; ---------------------------------------------------------------------- -;;; Optimizer for FSET. Should remove the need for a special handling of -;;; DEFUN as a toplevel form. +;;; Optimizer for FSET. Removes the need for a special handling of DEFUN as a +;;; toplevel form and also allows optimizing calls to DEFUN or DEFMACRO which +;;; are not toplevel, but which create no closures. +;;; +;;; The idea is as follows: when the function or macro to be defined is not a +;;; closure, we can use the auxiliary C functions c_def_c_*() instead of +;;; creating a closure and invoking si_fset(). However until the C2 phase of +;;; the compiler we do not know whether a function is a closure, hence the need +;;; for a c2fset. ;;; (defun c1fset (args) - ;; When the function or macro to be defined is not a closure, we can use the - ;; auxiliary C functions c_def_c_*() instead of creating a closure and - ;; invoking si_fset(). However until the C2 phase of the compiler we do not - ;; know whether a function is a closure, hence the need for a c2fset. (destructuring-bind (fname def &optional (macro nil) (pprint nil)) args - (let* ((args (mapcar #'c1expr args)) - (fun (second args))) - (if (and (eq (c1form-name fun) 'FUNCTION) - (not (eq (c1form-arg 0 fun) 'GLOBAL)) - (typep macro 'boolean) - (typep pprint '(or integer null))) - (make-c1form* 'SI:FSET :args - (c1form-arg 2 fun) ;; Function object - (c1expr fname) - macro - pprint - args) ;; The c1form, when we do not optimize - (c1call-global 'SI:FSET (list fname def macro pprint)))))) + (let* ((fun-form (c1expr def))) + (if (and (eq (c1form-name fun-form) 'FUNCTION) + (not (eq (c1form-arg 0 fun-form) 'GLOBAL))) + (let ((fun-object (c1form-arg 2 fun-form))) + (when (fun-no-entry fun-object) + (when macro + (cmperr "Declaration C-LOCAL used in macro ~a" (fun-name fun))) + (return-from c1fset + (make-c1form* 'SI:FSET :args fun-object nil nil nil nil))) + (when (and (typep macro 'boolean) + (typep pprint '(or integer null))) + (return-from c1fset + (make-c1form* 'SI:FSET :args + fun-object ;; Function object + (c1expr fname) + macro + pprint + ;; The c1form, when we do not optimize + (list (c1expr fname) + fun-form + (c1expr macro) + (c1expr pprint)))))))) + (c1call-global 'SI:FSET (list fname def macro pprint)))) (defun c2fset (fun fname macro pprint c1forms) + (when (fun-no-entry fun) + (wt-nl "(void)0; /* No entry created for " + (format nil "~A" (fun-name fun)) + " */") + ;; FIXME! Look at c2function! + (new-local fun) + (return-from c2fset)) (unless (and (not (fun-closure fun)) (eq *destination* 'TRASH)) (return-from c2fset @@ -701,28 +635,20 @@ ;;; Pass 1 top-levels. -(put-sysprop 'COMPILER-LET 'T1 #'t1compiler-let) -(put-sysprop 'EVAL-WHEN 'T1 #'t1eval-when) -(put-sysprop 'PROGN 'T1 #'t1progn) -(put-sysprop 'DEFUN 'T1 #'t1defun) -(put-sysprop 'MACROLET 'T1 #'t1macrolet) -(put-sysprop 'LOCALLY 'T1 #'t1locally) -(put-sysprop 'SYMBOL-MACROLET 'T1 #'t1symbol-macrolet) -(put-sysprop 'CLINES 'T1 't1clines) +(put-sysprop 'COMPILER-LET 'T1 #'c1compiler-let) +(put-sysprop 'EVAL-WHEN 'T1 #'c1eval-when) +(put-sysprop 'PROGN 'T1 #'c1progn) +(put-sysprop 'MACROLET 'T1 #'c1macrolet) +(put-sysprop 'LOCALLY 'T1 #'c1locally) +(put-sysprop 'SYMBOL-MACROLET 'T1 #'c1symbol-macrolet) (put-sysprop 'LOAD-TIME-VALUE 'C1 'c1load-time-value) (put-sysprop 'SI:FSET 'C1 'c1fset) ;;; Pass 2 initializers. +(put-sysprop 'COMPILER-LET 'T2 #'t2compiler-let) (put-sysprop 'DECL-BODY 't2 #'t2decl-body) (put-sysprop 'PROGN 'T2 #'t2progn) -(put-sysprop 'DEFUN 'T2 #'t2defun) (put-sysprop 'ORDINARY 'T2 #'t2ordinary) (put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value) (put-sysprop 'SI:FSET 'C2 'c2fset) - -;;; Pass 2 C function generators. - -(put-sysprop 'DECL-BODY 't3 #'t3decl-body) -(put-sysprop 'PROGN 'T3 #'t3progn) -(put-sysprop 'CLINES 'T3 't3clines) diff --git a/src/doc/todo.txt b/src/doc/todo.txt index 6e78ceb4e..fa77d4294 100644 --- a/src/doc/todo.txt +++ b/src/doc/todo.txt @@ -1,21 +1,6 @@ GOODIES: ======== -* In local functions, remove unused arguments. - -* It should be possible, in local functions that do not reference variables - from the enclosing code, and do not call any other functions that do it, - to remove the "lex*" arguments. - -* Inline local functions which are only referenced once. - -* Optimize out (multiple-value-call ... (values ...)). - -* Implement memory collection based on mmap() - -* Improve the garbage collector using kernel information about dirty - pages. - * Improve fixnum_times. * expand parse_namestring() to accept scaped strings, spaces, etc. @@ -29,10 +14,31 @@ GOODIES: them in the printer, so that both PRINT, PRINC, etc and FORMAT produce exactly the same representation of floating point numbers. -* Better integration between core streams and CLOS streams. - * Implemment type checking in structure slot setters. +COMPILER: +========= + +! Use conditions to signal warnings and errors. + +* In local functions, remove unused arguments. + +* It should be possible, in local functions that do not reference variables + from the enclosing code, and do not call any other functions that do it, + to remove the "lex*" arguments. + +* Optimize out (multiple-value-call ... (values ...)). + +* Implement memory collection based on mmap() + +* Improve the garbage collector using kernel information about dirty + pages. + +* In the list of objects *.data, remove those which are not referenced. + This requires major changes to the way locations are produced since + right now they are assigned in the C1 phase, while some objects are + discarded late in the C2 phase. + THREADS: ======== @@ -281,4 +287,4 @@ L20: (block-name 'BLOCK' . frame-id) * Funzione directory non funziona sotto DOS: la free chiamata - da setbuf fallisce. \ No newline at end of file + da setbuf fallisce. diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index c34e54232..c773c6134 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -23,16 +23,18 @@ The complete syntax of a lambda-list is: The doc-string DOC, if supplied, is saved as a FUNCTION doc and can be retrieved by (documentation 'NAME 'function)." (multiple-value-setq (body doc-string) (remove-documentation body)) - (let* ((block-name (if (and (consp name) - (eq (first name) 'setf)) - (second name) - name)) - (function `#'(ext::lambda-block ,block-name ,vl ,@body))) + (let* ((function `#'(ext::lambda-block ,name ,vl ,@body)) + (global-function `#'(ext::lambda-block ,name ,vl + (declare (si::c-global)) + ,@body))) (when *dump-defun-definitions* (print function) (setq function `(si::bc-disassemble ,function))) `(progn - (si::fset ',name ,function) + (eval-when (:execute) + (si::fset ',name ,function)) + (eval-when (:load-toplevel) + (si::fset ',name ,global-function)) ,@(si::expand-set-documentation name 'function doc-string) ',name))) diff --git a/src/lsp/loop2.lsp b/src/lsp/loop2.lsp index 0d6dc14a2..4066c6db7 100755 --- a/src/lsp/loop2.lsp +++ b/src/lsp/loop2.lsp @@ -468,7 +468,6 @@ code to be loaded. (defmacro loop-store-table-data (symbol table datum) - (declare (si::c-local)) `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) @@ -796,7 +795,6 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. after-loop epilogue &aux rbefore rafter flagvar) - (declare (si::c-local)) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) ;;All our work is done from these copies, working backwards from the end: