From 4e3189edddc82ef11c0a340d7d73dff1f40bb5b2 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 5 May 2004 08:38:07 +0000 Subject: [PATCH] Big changes in the way functions are compiled, unifying the code that handles DEFUN, DEFMACRO and LAMBDA, and fixing an important bug in the optimizer for tail-recursive calls. --- src/CHANGELOG | 10 + src/c/cfun.d | 6 +- src/c/macros.d | 6 +- src/c/unixint.d | 4 + src/cmp/cmpblock.lsp | 8 +- src/cmp/cmpcall.lsp | 33 +--- src/cmp/cmpdefs.lsp | 14 +- src/cmp/cmpeval.lsp | 11 +- src/cmp/cmpexit.lsp | 17 ++ src/cmp/cmpflet.lsp | 118 ++++++----- src/cmp/cmplam.lsp | 328 ++----------------------------- src/cmp/cmplet.lsp | 8 +- src/cmp/cmpmac.lsp | 2 + src/cmp/cmpmain.lsp | 8 +- src/cmp/cmpmulti.lsp | 1 + src/cmp/cmpspecial.lsp | 20 +- src/cmp/cmptag.lsp | 4 +- src/cmp/cmptop.lsp | 434 +++++++++-------------------------------- src/cmp/cmputil.lsp | 8 +- src/h/external.h | 2 +- src/lsp/evalmacros.lsp | 2 +- 21 files changed, 262 insertions(+), 782 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 0542c51b3..f83a7e6ab 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1752,6 +1752,16 @@ ECL 0.9d - Assignments to structures were not properly compiled in unsafe mode. + - The optimizer for tail-recursive calls has been fixed. Formerly + the check for tail-recursion was based on names, and this produced + an infinite loop: + (labels ((f1 (x) + (labels ((f1 (x) 2)) + (f1 x)))) + (f1 2)) + Now the compiler recognizes that the first call to (f1 x) refers + the innermost function, and there is no tail recursion. + * Documentation: - New manual page documents the scripting facilities of ECL diff --git a/src/c/cfun.d b/src/c/cfun.d index 046a9a401..8bc210b52 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -65,10 +65,12 @@ cl_def_c_function(cl_object sym, cl_object (*self)(), int narg) } void -cl_def_c_macro(cl_object sym, cl_object (*self)(cl_object, cl_object)) +cl_def_c_macro(cl_object sym, cl_object (*self)(), int narg) { si_fset(3, sym, - cl_make_cfun(self, sym, symbol_value(@'si::*cblock*'), 2), + (narg >= 0)? + cl_make_cfun(self, sym, symbol_value(@'si::*cblock*'), 2): + cl_make_cfun_va(self, sym, symbol_value(@'si::*cblock*')), Ct); } diff --git a/src/c/macros.d b/src/c/macros.d index cf1def6f8..acc0fe6e3 100644 --- a/src/c/macros.d +++ b/src/c/macros.d @@ -175,7 +175,7 @@ void init_macros(void) { ECL_SET(@'*macroexpand-hook*', @'funcall'); - cl_def_c_macro(@'or', or_macro); - cl_def_c_macro(@'and', and_macro); - cl_def_c_macro(@'when', when_macro); + cl_def_c_macro(@'or', or_macro, 2); + cl_def_c_macro(@'and', and_macro, 2); + cl_def_c_macro(@'when', when_macro, 2); } diff --git a/src/c/unixint.d b/src/c/unixint.d index 41745dc56..0acff1c6f 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -49,6 +49,10 @@ handle_signal(int sig) } } +/* + * TODO: Use POSIX signals, and in particular use sigaltstack to + * handle stack overflows gracefully. + */ static void signal_catcher(int sig) { diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 1923443c9..c1d6ed70a 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -31,8 +31,8 @@ (let ((block-name (first args))) (unless (symbolp block-name) (cmperr "The block name ~s is not a symbol." block-name)) - (let* ((blk (make-blk :var (make-var :name block-name :kind 'LEXICAL) - :name block-name)) + (let* ((blk-var (make-var :name block-name :kind 'LEXICAL)) + (blk (make-blk :var blk-var :name block-name)) (*blocks* (cons blk *blocks*)) (body (c1progn (rest args)))) (when (or (blk-ref-ccb blk) (blk-ref-clb blk)) @@ -40,7 +40,9 @@ (if (plusp (blk-ref blk)) ;; FIXME! By simplifying the type of a BLOCK form so much (it is ;; either NIL or T), we lose a lot of information. - (make-c1form* 'BLOCK :type (type-or (blk-type blk) (c1form-type body)) + (make-c1form* 'BLOCK + :local-vars (list blk-var) + :type (type-or (blk-type blk) (c1form-type body)) :args blk body) body)))) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 1cf110677..921f82243 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -142,28 +142,13 @@ (setq etype T)) (setf return-type etype) (setf (c1form-type (first args)) etype)))))) - (if (and (inline-possible fname) - (not (eq 'ARGS-PUSHED args)) - *tail-recursion-info* - (same-fname-p (first *tail-recursion-info*) fname) - (last-call-p) - (tail-recursion-possible) - (= (length args) (length (cdr *tail-recursion-info*)))) - ;; Tail-recursive case. - (let* ((*destination* 'TRASH) - (*exit* (next-label)) - (*unwind-exit* (cons *exit* *unwind-exit*))) - (c2psetq (cdr *tail-recursion-info*) args) - (wt-label *exit*) - (unwind-no-exit 'TAIL-RECURSION-MARK) - (wt-nl "goto TTL;") - (cmpnote "Tail-recursive call of ~s was replaced by iteration." - fname)) - ;; else - (let ((*inline-blocks* 0)) - (call-global fname (if (eq args 'ARGS-PUSHED) args (inline-args args)) - loc return-type narg) - (close-inline-blocks)))) + (let ((fun (find fname *global-funs* :key #'fun-name))) + (when (and fun (c2try-tail-recursive-call fun args)) + (return-from c2call-global))) + (let ((*inline-blocks* 0)) + (call-global fname (if (eq args 'ARGS-PUSHED) args (inline-args args)) + loc return-type narg) + (close-inline-blocks))) ;;; ;;; call-global: @@ -201,8 +186,8 @@ (unwind-exit loc)) ;; Call to a function defined in the same file. - ((setq fd (assoc fname *global-funs* :test #'same-fname-p)) - (let ((cfun (second fd))) + ((setq fd (find fname *global-funs* :test #'same-fname-p :key #'fun-name)) + (let ((cfun (fun-cfun fd))) (unwind-exit (call-loc fname (if (numberp cfun) (format nil "L~d" cfun) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 2ecebc93d..663778432 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -125,9 +125,11 @@ cfun ;;; The cfun for the function. (level 0) ;;; Level of lexical nesting for a function. (env 0) ;;; Size of env of closure. + (global nil) ;;; Global function: exported for outside this module. 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. + lambda ;;; Lambda c1-form for this function. ) (defstruct (blk (:include ref)) @@ -161,8 +163,9 @@ ) (defstruct (info) - (changed-vars nil) ;;; List of var-objects changed by the form. - (referred-vars nil) ;;; List of var-objects referred in the form. + (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. @@ -278,7 +281,7 @@ The default value is NIL.") ;;; ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. ;;; If possible, *tail-recursion-info* holds -;; ( fname required-arg .... required-arg ), +;; ( c1-lambda-form required-arg .... required-arg ), ;;; where each required-arg is a var-object. ;;; (defvar *tail-recursion-info* nil) @@ -340,7 +343,6 @@ The default value is NIL.") ;;; --cmptop.lsp-- ;;; -(defvar *funarg-vars*) (defvar *volatile*) (defvar *setjmps* 0) @@ -358,9 +360,9 @@ The default value is NIL.") ; watch out for multiple values. (defvar *global-vars* nil) -(defvar *global-funs* nil) ; holds { ( global-fun-name cfun ... ) }* +(defvar *global-funs* nil) ; holds { fun }* (defvar *linking-calls* nil) ; holds { ( global-fun-name vv ) }* -(defvar *local-funs* nil) ; holds { ( closurep fun funob ) }* +(defvar *local-funs* nil) ; holds { fun }* (defvar *top-level-forms* nil) ; holds { top-level-form }* ;;; ;;; top-level-form: diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index e26ad6d4e..c18c7ba3a 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -84,8 +84,10 @@ (let ((fun (local-function-ref fname))) (when fun (let* ((forms (c1args* args)) - (referred-vars (list (fun-var fun))) - (referred-local (list (fun-var fun))) + (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 (list (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,8 +103,9 @@ (setq forms (nreverse fl)))) (make-c1form* 'CALL-LOCAL :sp-change t - :referred-vars referred-local - :local-referred referred-vars + :referred-vars (append function-variable referred-vars) + :changed-vars changed-vars + :local-referred function-variable :type return-type :args fun forms))))) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index e0699aaea..08a22cb46 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -172,3 +172,20 @@ (return nil)) ((or (consp ue) (eq ue 'JUMP))) (t (baboon))))) + +(defun c2try-tail-recursive-call (fun args) + (when (and (listp args) ;; ARGS can be also 'ARGS-PUSHED + *tail-recursion-info* + (eq fun (first *tail-recursion-info*)) + (last-call-p) + (= (length args) (length (rest *tail-recursion-info*)))) + (let* ((*destination* 'TRASH) + (*exit* (next-label)) + (*unwind-exit* (cons *exit* *unwind-exit*))) + (c2psetq (cdr *tail-recursion-info*) args) + (wt-label *exit*)) + (unwind-no-exit 'TAIL-RECURSION-MARK) + (wt-nl "goto TTL;") + (cmpnote "Tail-recursive call of ~s was replaced by iteration." + (fun-name fun)) + t)) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 9fae95af2..b07eec8d5 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -12,7 +12,7 @@ (in-package "COMPILER") -(defun c1flet (args &aux body ss ts is other-decl +(defun c1flet (args &aux body-c1form body ss ts is other-decl (defs '()) (local-funs '())) (check-args-number 'FLET args 1) ;; On a first round, we extract the definitions of the functions, @@ -34,34 +34,38 @@ (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) - (setq body (c1decl-body other-decl body)))) + (setq body-c1form (c1decl-body other-decl body)))) ;; Now we can compile the function themselves. Notice that we have ;; emptied *fun* so that the functions do not see each other (that is ;; the difference with LABELS). In the end - ;; LOCAL-FUNS = ( { ( fun-object lambda-c1form ) }* ). + ;; LOCAL-FUNS = ( { fun-object }* ). (dolist (def (nreverse defs)) - (let ((fun (car def)) lam CB/LB) + (let ((fun (car def)) CB/LB) (when (plusp (fun-ref fun)) - (setq CB/LB (if (fun-ref-ccb fun) 'CB 'LB)) - (setq lam + (setf local-funs (cons fun local-funs) + CB/LB (if (fun-ref-ccb fun) 'CB 'LB) + (fun-lambda fun) (let ((*funs* (cons CB/LB *funs*)) (*vars* (cons CB/LB *vars*)) (*blocks* (cons CB/LB *blocks*)) (*tags* (cons CB/LB *tags*))) (c1lambda-expr (second def) (si::function-block-name (fun-name fun))))) - (push (list fun lam) local-funs) (setf (fun-cfun fun) (next-cfun))))) ;; cant do in previous loop since closed var may be in later function - (dolist (fun-lam local-funs) - (setf (fun-closure (first fun-lam)) (closure-p (second fun-lam)))) + (dolist (fun local-funs) + ;; FIXME! This should be in C2LOCALS + (setf (fun-closure fun) (closure-p (fun-lambda fun)))) (if local-funs - (make-c1form* 'LOCALS :type (c1form-type body) - :args (nreverse local-funs) body nil) - body)) + (let ((*funs* (append local-funs *funs*)) + (*vars* *vars*)) + ;(setf body-c1form (c1decl-body other-decl body)) + (make-c1form* 'LOCALS :type (c1form-type body-c1form) + :args (nreverse local-funs) body-c1form nil)) + body-c1form)) (defun closure-p (funob) ;; It's a closure if inside its body there is a reference (var) @@ -86,8 +90,8 @@ (*env-lvl* *env-lvl*) env-grows) ;; create location for each function which is returned, ;; either in lexical: - (dolist (def funs) - (let* ((fun (car def)) (var (fun-var fun))) + (dolist (fun funs) + (let* ((var (fun-var fun))) (when (plusp (var-ref var)) ; the function is returned (unless (member (var-kind var) '(LEXICAL CLOSURE)) (setf (var-loc var) (next-lcl)) @@ -104,15 +108,16 @@ (wt "volatile cl_object env" (incf *env-lvl*) " = env" env-lvl ";"))) ;; bind such locations: ;; - first create binding (because of possible circularities) - (dolist (def funs) - (let* ((fun (car def)) (var (fun-var fun))) + (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 (bind nil var)))) ;; - then assign to it - (dolist (def funs) - (let* ((fun (car def)) (var (fun-var fun))) + (dolist (fun funs) + ;(setf (fun-closure fun) (closure-p (fun-lambda fun))) + (let* ((var (fun-var fun))) (when (and var (plusp (var-ref var))) (set-var (list 'MAKE-CCLOSURE fun) var)))) ;; We need to introduce a new lex vector when lexical variables @@ -121,9 +126,9 @@ (when (plusp *lex*) (incf level)) ;; create the functions: - (dolist (def funs) - (let* ((fun (car def)) (var (fun-var fun)) previous) - (when (setq previous (new-local level fun (second def))) + (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))))) @@ -131,7 +136,7 @@ (c2expr body) (when block-p (wt-nl "}"))) -(defun c1labels (args &aux body ss ts is other-decl defs fun local-funs +(defun c1labels (args &aux body-c1form body ss ts is other-decl defs fun local-funs fnames (*funs* *funs*)) (check-args-number 'LABELS args 1) @@ -156,7 +161,7 @@ (let ((*vars* *vars*)) (c1add-globals ss) (check-vdecl nil ts is) - (setq body (c1decl-body other-decl body))) + (setq body-c1form (c1decl-body other-decl body))) (do ((finished)) (finished) @@ -171,9 +176,10 @@ (*funs* (cons 'LB *funs*)) (*blocks* (cons 'LB *blocks*)) (*tags* (cons 'LB *tags*))) - (let ((lam (c1lambda-expr (third def) - (si::function-block-name (fun-name fun))))) - (push (list fun lam) local-funs))) + (setf (fun-lambda fun) + (c1lambda-expr (third def) + (si::function-block-name (fun-name fun)))) + (push fun local-funs)) (setf (second def) T))) ) @@ -188,26 +194,29 @@ (when (second def) ;; also processed as local, e.g.: ;; (defun foo (z) (labels ((g () z) (h (y) #'g)) (list (h z) (g)))) - (setq local-funs (delete fun local-funs :key #'car))) + (setq local-funs (delete fun local-funs))) (let ((*vars* (cons 'CB *vars*)) (*funs* (cons 'CB *funs*)) (*blocks* (cons 'CB *blocks*)) (*tags* (cons 'CB *tags*))) - (let ((lam (c1lambda-expr (third def) - (si::function-block-name (fun-name fun))))) - (push (list fun lam) local-funs))) + (setf (fun-lambda fun) + (c1lambda-expr (third def) + (si::function-block-name (fun-name fun)))) + (push fun local-funs)) (setf (car def) NIL))) ; def processed ) - (dolist (fun-lam local-funs) - (setq fun (first fun-lam)) - (setf (fun-closure fun) (closure-p (second fun-lam))) + (dolist (fun local-funs) + ;; FIXME! This should be in C2LOCALS + (setf (fun-closure fun) (closure-p (fun-lambda fun))) (setf (fun-cfun fun) (next-cfun))) (if local-funs - (make-c1form* 'LOCALS :type (c1form-type body) - :args local-funs body T) ; T means labels - body)) + (let* ((*vars* *vars*)) + ;(setq body-c1form (c1decl-body other-decl body)) + (make-c1form* 'LOCALS :type (c1form-type body-c1form) + :args local-funs body-c1form T)) ; T means labels + body-c1form)) (defun c1locally (args) (multiple-value-bind (body ss ts is other-decl) @@ -283,32 +292,17 @@ (c2call-local fun args narg) (wt-nl "}") (return-from c2call-local))) - (cond - ((and (listp args) - *tail-recursion-info* - (same-fname-p (car *tail-recursion-info*) (fun-name fun)) - (eq *exit* 'RETURN) - (tail-recursion-possible) - (= (length args) (length (cdr *tail-recursion-info*)))) - (let* ((*destination* 'TRASH) - (*exit* (next-label)) - (*unwind-exit* (cons *exit* *unwind-exit*))) - (c2psetq (cdr *tail-recursion-info*) args) - (wt-label *exit*)) - (unwind-no-exit 'TAIL-RECURSION-MARK) - (wt-nl "goto TTL;") - (cmpnote "Tail-recursive call of ~s was replaced by iteration." - (fun-name fun))) - (t (let ((*inline-blocks* 0) - (fun (format nil "LC~d" (fun-cfun fun))) - (lex-level (fun-level fun)) - (closure-p (fun-closure fun)) - (fname (fun-name fun))) - (unwind-exit - (list 'CALL-LOCAL fun lex-level closure-p - (if (eq args 'ARGS-PUSHED) 'ARGS-PUSHED (coerce-locs (inline-args args))) - narg fname)) - (close-inline-blocks))))) + (unless (c2try-tail-recursive-call fun args) + (let ((*inline-blocks* 0) + (fun (format nil "LC~d" (fun-cfun fun))) + (lex-level (fun-level fun)) + (closure-p (fun-closure fun)) + (fname (fun-name fun))) + (unwind-exit + (list 'CALL-LOCAL fun lex-level closure-p + (if (eq args 'ARGS-PUSHED) 'ARGS-PUSHED (coerce-locs (inline-args args))) + narg fname)) + (close-inline-blocks)))) (defun wt-call-local (fun lex-lvl closure-p args narg fname) (declare (fixnum lex-lvl)) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 536ec8c2c..34a78b2a1 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -119,12 +119,12 @@ (let ((new-vars (ldiff *vars* old-vars))) (setq body (c1decl-body other-decls body)) (dolist (var new-vars) - (check-vref var))) - - (make-c1form* 'LAMBDA - :args (list requireds optionals rest key-flag keywords - allow-other-keys) - doc body))) + (check-vref var)) + (make-c1form* 'LAMBDA + :local-vars new-vars + :args (list requireds optionals rest key-flag keywords + allow-other-keys) + doc body)))) #| Steps: 1. defun creates declarations for requireds + va_alist @@ -152,22 +152,22 @@ (labels nil) (varargs (or optionals rest keywords allow-other-keys)) simple-varargs - (*tail-recursion-info* nil) (*unwind-exit* *unwind-exit*) (*env* *env*) (block-p nil) (last-arg)) (declare (fixnum nreq nkey)) - (when (and fname ;; named function - ;; no required appears in closure, - (dolist (var (car lambda-list) t) - (declare (type var var)) - (when (var-ref-ccb var) (return nil))) - (null (second lambda-list)) ;; no optionals, - (null (third lambda-list)) ;; no rest parameter, and - (null (fourth lambda-list))) ;; no keywords. - (setf *tail-recursion-info* (cons fname (car lambda-list)))) + (if (and fname ;; named function + ;; no required appears in closure, + (dolist (var (car lambda-list) t) + (declare (type var var)) + (when (var-ref-ccb var) (return nil))) + (null (second lambda-list)) ;; no optionals, + (null (third lambda-list)) ;; no rest parameter, and + (null (fourth lambda-list))) ;; no keywords. + (setf *tail-recursion-info* (cons *tail-recursion-info* (car lambda-list))) + (setf *tail-recursion-info* nil)) ;; For local entry functions arguments are processed by t3defun. ;; They must have a fixed number of arguments, no optionals, rest, etc. @@ -335,302 +335,6 @@ (when block-p (wt-nl "}")) ) -;;; The DEFMACRO compiler. - -;;; valid lambda-list to DEFMACRO is: -;;; -;;; ( [ &whole sym ] -;;; [ &environment sym ] -;;; { v }* -;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] -;;; { [ { &rest | &body } v ] -;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* -;;; [ &allow-other-keys ]] -;;; [ &aux { sym | ( v [ init ] ) }* ] -;;; | . sym } -;;; ) -;;; -;;; where v is short for { defmacro-lambda-list | sym }. -;;; Defmacro-lambda-list is defined as: -;;; -;;; ( { v }* -;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ] -;;; { [ { &rest | &body } v ] -;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }* -;;; [ &allow-other-keys ]] -;;; [ &aux { sym | ( v [ init ] ) }* ] -;;; | . sym } -;;; ) - -;(defvar *vnames*) -> vnames -;(defvar *dm-info*)-> dm-info -;(defvar *dm-vars*)-> dm-vars - -(defun c1dm (macro-name vl body - &aux (whole nil) (env nil) - (vnames nil) (dm-vars nil) - (setjmps *setjmps*) ; Beppe - doc ss is ts other-decls ppn) - - (multiple-value-setq (body ss ts is other-decls doc) (c1body body t)) - (setq body (list (list* 'BLOCK macro-name body))) - - (c1add-globals ss) - - (when (and (listp vl) (eq (car vl) '&WHOLE)) - (push (second vl) vnames) - (setq whole (c1make-var (second vl) ss is ts)) - (push whole dm-vars) - (push-vars whole) - (setq vl (cddr vl)) - ) - (do ((x vl (cdr x))) - ((atom x)) - (when (eq (car x) '&ENVIRONMENT) - (push (second x) vnames) - (setq env (c1make-var (second x) ss is ts)) - (push env dm-vars) - (push-vars env) - (setq vl (nconc (ldiff vl x) (cddr x))))) - - (labels ((c1dm-vl (vl ss is ts) - (do ((optionalp nil) (restp nil) (keyp nil) - (allow-other-keys-p nil) (auxp nil) - (requireds nil) (optionals nil) (rest nil) (key-flag nil) - (keywords nil) (auxs nil) (allow-other-keys nil) - (n 0) (ppn nil)) - ((not (consp vl)) - (when vl - (when restp (dm-bad-key '&REST)) - (setq rest (c1dm-v vl ss is ts))) - (values (list (nreverse requireds) (nreverse optionals) rest key-flag - (nreverse keywords) allow-other-keys (nreverse auxs)) - ppn) - ) - (let ((v (car vl))) - (declare (object v)) - (cond - ((eq v '&OPTIONAL) - (when optionalp (dm-bad-key '&OPTIONAL)) - (setq optionalp t) - (pop vl)) - ((or (eq v '&REST) (eq v '&BODY)) - (when restp (dm-bad-key v)) - (setq rest (c1dm-v (second vl) ss is ts)) - (setq restp t optionalp t) - (setq vl (cddr vl)) - (when (eq v '&BODY) (setq ppn n))) - ((eq v '&KEY) - (when keyp (dm-bad-key '&KEY)) - (setq keyp t restp t optionalp t key-flag t) - (pop vl)) - ((eq v '&ALLOW-OTHER-KEYS) - (when (or (not keyp) allow-other-keys-p) - (dm-bad-key '&ALLOW-OTHER-KEYS)) - (setq allow-other-keys-p t allow-other-keys t) - (pop vl)) - ((eq v '&AUX) - (when auxp (dm-bad-key '&AUX)) - (setq auxp t allow-other-keys-p t keyp t restp t optionalp t) - (pop vl)) - (auxp - (let (x init) - (cond ((symbolp v) (setq x v init (c1nil))) - (t (setq x (car v)) - (if (endp (cdr v)) - (setq init (c1nil)) - (setq init (c1expr (second v)))))) - (push (list (c1dm-v x ss is ts) init) auxs)) - (pop vl)) - (keyp - (let (x k init (sv nil)) - (cond ((symbolp v) - (setq x v - k (intern (string v) 'KEYWORD) - init (c1nil))) - (t (if (symbolp (car v)) - (setq x (car v) - k (intern (string (car v)) 'KEYWORD)) - (setq x (cadar v) k (caar v))) - (cond ((endp (cdr v)) (setq init (c1nil))) - (t (setq init (c1expr (second v))) - (unless (endp (cddr v)) - (setq sv (third v))))))) - (push (list k (c1dm-v x ss is ts) init - (if sv (c1dm-v sv ss is ts) nil)) - keywords) - ) - (pop vl)) - (optionalp - (let (x init (sv nil)) - (cond ((symbolp v) (setq x v init (c1nil))) - (t (setq x (car v)) - (cond ((endp (cdr v)) - (setq init (c1nil))) - (t (setq init (c1expr (second v))) - (unless (endp (cddr v)) - (setq sv (third v))))))) - (push (list (c1dm-v x ss is ts) init - (if sv (c1dm-v sv ss is ts) nil)) - optionals)) - (pop vl) - (incf n) - ) - (t (push (c1dm-v v ss is ts) requireds) - (pop vl) - (incf n)) - ))) - ) - - (c1dm-v (v ss is ts) - (cond ((symbolp v) - (push v vnames) - (setq v (c1make-var v ss is ts)) - (push-vars v) - (push v dm-vars) - v) - (t (c1dm-vl v ss is ts)))) - ) - (multiple-value-setq (vl ppn) (c1dm-vl vl ss is ts))) - - (check-vdecl vnames ts is) - (setq body (c1decl-body other-decls body)) - (unless (eql setjmps *setjmps*) - (put-sysprop macro-name 'CONTAINS-SETJMP t)) - (dolist (v dm-vars) (check-vref v)) - - (list doc ppn whole env vl body) - ) - -(defun c1dm-bad-key (key) - (cmperr "Defmacro-lambda-list contains illegal use of ~s." key)) - -(defun c2dm (name whole env vl body) - (let ((lcl (next-lcl))) - (when whole - (check-vref whole) - (bind lcl whole))) - (let ((lcl (next-lcl))) - (when env - (check-vref env) - (bind lcl env))) - (labels ((reserve-v (v) - (if (consp v) - (reserve-vl v) - (when (local v) - (setf (var-kind v) :OBJECT - (var-loc v) (next-lcl)) - (wt "," v)))) - - (reserve-vl (vl) - (dolist (var (car vl)) (reserve-v var)) - (dolist (opt (second vl)) - (reserve-v (car opt)) - (when (third opt) (reserve-v (third opt)))) - (when (third vl) (reserve-v (third vl))) - (dolist (kwd (fifth vl)) - (reserve-v (second kwd)) - (when (fourth kwd) (reserve-v (fourth kwd)))) - (dolist (aux (seventh vl)) - (reserve-v (car aux)))) - - (dm-bind-loc (v loc) - (if (consp v) - (let ((lcl (make-lcl-var))) - (wt-nl "{cl_object " lcl "= " loc ";") - (dm-bind-vl v lcl) - (wt "}")) - (bind loc v))) - - (dm-bind-init (para &aux (v (first para)) (init (second para))) - (if (consp v) - (let* ((*inline-blocks* 0) ; used by inline-args - (lcl (make-lcl-var)) - (loc (first (coerce-locs (inline-args (list init)))))) - (wt-nl lcl "= " loc ";") - (dm-bind-vl v lcl) - (close-inline-blocks)) - (bind-init v init))) - - (dm-bind-vl (vl lcl &aux - (requireds (car vl)) (optionals (second vl)) - (rest (third vl)) (key-flag (fourth vl)) - (keywords (fifth vl)) - (allow-other-keys (sixth vl)) - (auxs (seventh vl)) - ) - (declare (object requireds optionals rest key-flag keywords - allow-other-keys auxs)) - (do ((reqs requireds (cdr reqs))) - ((endp reqs)) - (declare (object reqs)) - (when (compiler-check-args) - (wt-nl "if(endp(" lcl "))FEinvalid_macro_call(" - (add-symbol name) ");")) - (dm-bind-loc (car reqs) `(CAR ,lcl)) - (when (or (cdr reqs) optionals rest key-flag - (compiler-check-args)) - (wt-nl lcl "=CDR(" lcl ");"))) - (do ((opts optionals (cdr opts)) - (opt)) - ((endp opts)) - (declare (object opts opt)) - (setq opt (car opts)) - (wt-nl "if(endp(" lcl ")){") - (let ((*env* *env*) - (*unwind-exit* *unwind-exit*)) - (dm-bind-init opt) - (when (third opt) (dm-bind-loc (third opt) nil)) - ) - (wt-nl "} else {") - (dm-bind-loc (car opt) `(CAR ,lcl)) - (when (third opt) (dm-bind-loc (third opt) t)) - (when (or (cdr opts) rest key-flag (compiler-check-args)) - (wt-nl lcl "=CDR(" lcl ");")) - (wt "}")) - (when rest (dm-bind-loc rest lcl)) - (when keywords - (let* ((loc1 (make-lcl-var))) - (wt-nl "{cl_object " loc1 ";") - (dolist (kwd keywords) - (wt-nl loc1 "=ecl_getf(" lcl "," (add-symbol (car kwd)) - ",OBJNULL);") - (wt-nl "if(" loc1 "==OBJNULL){") - (let ((*env* *env*) - (*unwind-exit* *unwind-exit*)) - (dm-bind-init (cdr kwd)) - (when (fourth kwd) (dm-bind-loc (fourth kwd) nil)) - (wt-nl "} else {")) - (dm-bind-loc (second kwd) loc1) - (when (fourth kwd) (dm-bind-loc (fourth kwd) t)) - (wt "}")) - (wt "}"))) - (when (and (compiler-check-args) - (null rest) - (null key-flag)) - (wt-nl "if(!endp(" lcl "))FEinvalid_macro_call(" - (add-symbol name) ");")) - (when (and (compiler-check-args) - key-flag - (not allow-other-keys)) - (wt-nl "check_other_key(" lcl "," (length keywords)) - (dolist (kwd keywords) - (wt "," (add-symbol (car kwd)))) - (wt ");")) - (dolist (aux auxs) - (dm-bind-init aux))) - ) - - (let ((lcl (make-lcl-var))) - (wt-nl "{cl_object " lcl "=CDR(V1)") - (reserve-vl vl) ; declare variables for pattern - (wt ";") - (dm-bind-vl vl lcl)) - ) - (c2expr body) - (wt "}") - ) - (defun optimize-funcall/apply-lambda (lambda-form arguments apply-p &aux body apply-list apply-var let-vars extra-stmts all-keys) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index cf883a89f..91daef496 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -63,9 +63,11 @@ (used-vars '()) (used-forms '())) ((null vars) + (setf used-vars (nreverse used-vars)) (make-c1form* 'LET :type (c1form-type body) :volatile (not (eql setjmps *setjmps*)) - :args (nreverse used-vars) (nreverse used-forms) body)) + :local-vars used-vars + :args used-vars (nreverse used-forms) body)) (let* ((var (first vars)) (form (and-form-type (var-type var) (first forms) (var-name var) :unsafe "In LET body")) @@ -280,9 +282,11 @@ (used-vars '()) (used-forms '())) ((null vs) + (setf used-vars (nreverse used-vars)) (make-c1form* 'LET* :type (c1form-type body) :volatile (not (eql setjmps *setjmps*)) - :args (nreverse used-vars) (nreverse used-forms) body)) + :local-vars used-vars + :args used-vars (nreverse used-forms) body)) (let* ((var (first vs)) (form (and-form-type (var-type var) (car fs) (cadar args) :unsafe "~&;;; In LET* body")) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 346fb8c91..4499f2ada 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -113,6 +113,8 @@ (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)) ((consp subform) (c1form-add-info form subform))))) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 82191b445..5f4e12b12 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -582,15 +582,10 @@ Cannot compile ~a." (open h-file :direction :output) null-stream)) (*error-count* 0) - (t3local-fun (symbol-function 'T3LOCAL-FUN)) - (t3fun (get-sysprop 'DEFUN 'T3))) + (t3local-fun (symbol-function 'T3LOCAL-FUN))) (with-lock (+load-compile-lock+) (unwind-protect (progn - (put-sysprop 'DEFUN 'T3 - #'(lambda (&rest args) - (let ((*compiler-output1* *standard-output*)) - (apply t3fun args)))) (setf (symbol-function 'T3LOCAL-FUN) #'(lambda (&rest args) (let ((*compiler-output1* *standard-output*)) @@ -607,7 +602,6 @@ Cannot compile ~a." (data-dump data-file) (init-env) ) - (put-sysprop 'DEFUN 'T3 t3fun) (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) (when h-file (close *compiler-output2*))))) nil diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 3dcb1a0ed..3247fc97c 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -199,6 +199,7 @@ (setq body (c1decl-body other-decls body)) (dolist (var vars) (check-vref var)) (make-c1form* 'MULTIPLE-VALUE-BIND :type (c1form-type body) + :local-vars vars :args vars init-form body) ) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 3c1a67e15..ac227dbdb 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -126,31 +126,33 @@ (setf (fun-closure fun) (> *env* 0)) (new-local 0 fun funob) ; 0 was *level* (unwind-exit `(MAKE-CCLOSURE ,fun))) + ;; Notice that C1FSET relies on the meaning CONSTANT = (NOT CLOSURE)! (CONSTANT (unwind-exit (fun-var fun))))) ;;; Mechanism for sharing code. -(defun new-local (level fun funob) +(defun new-local (level fun &optional (funob (fun-lambda fun))) ;; returns the previous function or NIL. (declare (type fun fun)) (let ((previous (dolist (local *local-funs*) - (when (and (= *env* (fun-env (second local))) + (when (and (= *env* (fun-env local)) ;; closures must be embedded in env of ;; same size - (similar funob (third local))) - (return (second local))))) - (closure (when (fun-closure fun) 'CLOSURE))) + (similar funob (fun-lambda local))) + (return local))))) (if previous (progn - (if closure + (if (fun-closure fun) (cmpnote "Sharing code for closure") (cmpnote "Sharing code for local function ~A" (fun-name fun))) - (setf (fun-cfun fun) (fun-cfun previous)) + (setf (fun-cfun fun) (fun-cfun previous) + (fun-lambda fun) (fun-lambda previous)) previous) (progn (setf (fun-level fun) (if (fun-ref-ccb fun) 0 level) - (fun-env fun) *env*) - (push (list closure fun funob) *local-funs*) + (fun-lambda fun) funob + (fun-env fun) *env* + *local-funs* (cons fun *local-funs*)) NIL)))) (defun wt-fdefinition (fun-name) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index f63745bb6..7d4c96cdc 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -70,6 +70,7 @@ (when (jumps-to-p (car w) name) (setq end w))))))) +;; FIXME! The variable name should not be a usable one! (defun c1tagbody (body &aux (*tags* *tags*) (tag-var (make-var :name 'TAGBODY :kind NIL)) (tag-index 0)) @@ -100,7 +101,8 @@ (when (var-ref-ccb tag-var) (incf *setjmps*)) (add-loop-registers body1) - (make-c1form* 'TAGBODY :args tag-var body1)) + (make-c1form* 'TAGBODY :local-vars (list tag-var) + :args tag-var body1)) (make-c1form* 'PROGN :args (nreverse (cons (c1nil) body1)))))) (defun c2tagbody (tag-loc body) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 0e12ab280..b7658d025 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -21,16 +21,15 @@ (push (t1expr* form) *top-level-forms*))) (defun t1expr* (form &aux (*current-form* form) (*first-error* t) - *funarg-vars* (*setjmps* 0)) ;(let ((*print-level* 3)) (print form)) (catch *cmperr-tag* (when (consp form) - (let ((fun (car form)) (args (cdr form)) fd setf-symbol) ; #+cltl2 + (let ((fun (car form)) (args (cdr form)) fd) + (when *compile-print* (print-current-form)) (cond ((symbolp fun) (cond ((setq fd (get-sysprop fun 'T1)) - (when *compile-print* (print-current-form)) (funcall fd args)) ((get-sysprop fun 'C1) (t1ordinary form)) ((setq fd (macro-function fun)) @@ -60,23 +59,19 @@ (do ((lfs *local-funs* (cdr lfs))) ((eq (cdr lfs) *emitted-local-funs*) (setq *emitted-local-funs* lfs) - (when *compile-print* - (print-emitting (fun-name (cadar lfs)))) (locally (declare (notinline t3local-fun)) ;; so disassemble can redefine it - (apply 't3local-fun (car lfs))))))) + (t3local-fun (first lfs))))))) (defun t3expr (form) ;(pprint (cons 'T3 form)) (when form (emit-local-funs) - (setq *funarg-vars* nil) (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) - (setq *funarg-vars* nil))) + (emit-local-funs))) (defun ctop-write (name h-pathname data-pathname &key system-p shared-data @@ -224,77 +219,39 @@ (or (and (symbolp name) (get-sysprop name 'Lfun)) (next-cfun))) -(defun t1defun (args &aux (setjmps *setjmps*)) +(defun t1defun (args) (check-args-number 'DEFUN args 2) (when *compile-time-too* (cmp-eval (cons 'DEFUN args))) - (let* (lambda-expr - (fname (car args)) - (cfun (exported-fname fname)) + (let* ((fname (car args)) + (setjmps *setjmps*) + (lambda-expr (c1lambda-expr (cdr args) (si::function-block-name fname))) (no-entry nil) - (doc nil) - output) - - (setq lambda-expr (c1lambda-expr (cdr args) (si::function-block-name fname))) + (doc nil)) (unless (eql setjmps *setjmps*) (setf (c1form-volatile lambda-expr) t)) (multiple-value-bind (decl body doc) (si::process-declarations (cddr args) nil) - (cond ((and (assoc 'si::c-local decl) *allow-c-local-declaration*) + (cond ((and *allow-c-local-declaration* (assoc 'si::c-local decl)) (setq no-entry t)) ((setq doc (si::expand-set-documentation fname 'function doc)) (t1expr `(progn ,@doc))))) (add-load-time-values) - (setq output (new-defun fname cfun lambda-expr *special-binding* no-entry)) - (when - (and - (symbolp fname) - (get-sysprop fname 'PROCLAIMED-FUNCTION) - (let ((lambda-list (c1form-arg 0 lambda-expr))) - (declare (list lambda-list)) - (and (null (second lambda-list)) ; no optional - (null (third lambda-list)) ; no rest - (null (fourth lambda-list)) ; no keyword - (< (length (car lambda-list)) lambda-parameters-limit)))) - (flet - ((make-inline-string (cfun args) - (if (null args) - (format nil "LI~a()" cfun) - (let ((o (make-array 100 :element-type 'BASE-CHAR - :fill-pointer 0))) - (format o "LI~a(" cfun) - (do ((l args (cdr l)) - (n 0 (1+ n))) - ((endp (cdr l)) - (format o "#~d)" n)) - (declare (fixnum n)) - (format o "#~d," n)) - o)))) - (let ((pat (get-sysprop fname 'PROCLAIMED-ARG-TYPES)) - (prt (get-sysprop fname 'PROCLAIMED-RETURN-TYPE))) - (push (list fname pat prt t - (not (member-type prt - '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT))) - (make-inline-string cfun pat)) - *inline-functions*)))) + (setq output (new-defun fname lambda-expr no-entry)) output)) ;;; Mechanism for sharing code: ;;; FIXME! Revise this 'DEFUN stuff. -(defun new-defun (fname cfun lambda-expr special-binding &optional no-entry) - (let ((previous (dolist (form *global-funs*) - (when (and #+nil(eq 'DEFUN (car form)) - (equal special-binding (fifth form)) - (similar lambda-expr (third form))) - (return (second form)))))) - (if (and previous (not (get-sysprop fname 'Lfun))) - (progn - (cmpnote "Sharing code for function ~A" fname) - (make-c1form* 'DEFUN :args fname previous nil special-binding - *funarg-vars* no-entry)) - (let ((fun-desc (list fname cfun lambda-expr special-binding - *funarg-vars* no-entry))) - (push fun-desc *global-funs*) - (apply #'make-c1form* 'DEFUN :args fun-desc))))) +(defun new-defun (fname lambda-expr &optional no-entry) + (let ((cfun (exported-fname fname))) + (unless (stringp cfun) + (dolist (f *global-funs*) + (when (similar lambda-expr (fun-lambda f)) + (cmpnote "Sharing code among functions ~A and ~A" fname (fun-name f)) + (setf cfun (fun-cfun f) lambda-expr nil) + (return)))) + (let ((fun (make-fun :name fname :cfun cfun :global t :lambda lambda-expr))) + (push fun *global-funs*) + (make-c1form* 'DEFUN :args fun no-entry)))) (defun similar (x y) (or (equal x y) @@ -309,125 +266,18 @@ (typep y 'VECTOR) (every #'similar x y)))) -(defun wt-if-proclaimed (fname cfun vv lambda-expr) - (when (fast-link-proclaimed-type-p fname) - (let ((arg-c (length (car (third lambda-expr)))) - (arg-p (length (get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) - (if (= arg-c arg-p) - (cmpwarn - " ~a is proclaimed but not in *inline-functions* ~ - ~%T1defun could not assure suitability of args for C call" fname) - (cmpwarn - "Number of proclaimed args for ~a was ~a. ~ - ~%;;; Its definition had ~a." fname arg-p arg-c))))) - -(defun t2defun (fname cfun lambda-expr sp funarg-vars no-entry) +(defun t2defun (fun no-entry) (declare (ignore sp funarg-vars)) - (if no-entry - (return-from t2defun nil)) - (let ((vv (add-object fname))) + ;; 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))) (if (numberp cfun) (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)L" cfun ");") - (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)" cfun ");")) - (when (and (symbolp fname) (get-sysprop fname 'PROCLAIMED-FUNCTION)) - (wt-if-proclaimed fname cfun vv lambda-expr)))) - -(defun t3defun (fname cfun lambda-expr sp funarg-vars no-entry - &aux inline-info lambda-list requireds - (*current-form* (list 'DEFUN fname)) - (*volatile* (when lambda-expr - (c1form-volatile* lambda-expr))) - (*lcl* 0) (*temp* 0) (*max-temp* 0) - (*lex* *lex*) (*max-lex* *max-lex*) - (*env* *env*) (*max-env* 0) (*level* *level*)) - (setq *funarg-vars* funarg-vars) - (when *compile-print* (print-emitting fname)) - (when lambda-expr ; Not sharing code. - (setq lambda-list (c1form-arg 0 lambda-expr) - requireds (car lambda-list)) - - (if (setq inline-info (assoc fname *inline-functions* :test #'same-fname-p)) - - ;; Local entry - (let* ((*exit* (case (third inline-info) - (FIXNUM 'RETURN-FIXNUM) - (CHARACTER 'RETURN-CHARACTER) - (LONG-FLOAT 'RETURN-LONG-FLOAT) - (SHORT-FLOAT 'RETURN-SHORT-FLOAT) - (otherwise 'RETURN-OBJECT))) - (*unwind-exit* (list *exit*)) - (*destination* *exit*) - (*reservation-cmacro* (next-cmacro))) - - ;; Add global entry information. - (push (list fname cfun (second inline-info) (third inline-info)) - *global-entries*) - (wt-comment "local entry for function " fname) - (let*((ret-type (rep-type-name (lisp-type->rep-type (third inline-info)))) - (string - (with-output-to-string (*compiler-output1*) - (wt-nl1 "static " ret-type " LI" cfun "(") - (do* ((vl requireds (cdr vl)) - (types (second inline-info) (cdr types)) - var rep-type - (lcl (1+ *lcl*) (1+ lcl))) - ((endp vl)) - (declare (fixnum lcl)) - (setq var (first vl) - rep-type (lisp-type->rep-type (car types))) - (when (member-type (car types) - '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)) - ;; so that c2lambda-expr will know its proper type. - (setf (var-kind var) rep-type)) - (unless (eq vl requireds) (wt ",")) - (wt *volatile* (rep-type-name rep-type) " ") - (wt-lcl lcl)) - (wt ")")))) - (wt-h string ";") - (wt-nl1 string)) - - ;; Now the body. - (let ((*tail-recursion-info* (cons fname requireds)) - (*unwind-exit* *unwind-exit*)) - (wt-nl1 "{") - (wt-function-prolog nil 'LOCAL-ENTRY) - (c2lambda-expr lambda-list (c1form-arg 2 lambda-expr) cfun fname - nil 'LOCAL-ENTRY) - (wt-nl1 "}") - (wt-function-epilogue))) - - ;; normal (non proclaimed) function: - (let ((*exit* 'RETURN) (*unwind-exit* '(RETURN)) - (*destination* 'RETURN) (*reservation-cmacro* (next-cmacro)) - (va_args (or (second lambda-list) - (third lambda-list) - (fourth lambda-list)))) - - (wt-comment "function definition for " fname) - (if (numberp cfun) - (progn - (wt-nl1 "static cl_object L" cfun "(cl_narg narg") - (wt-h "static cl_object L" cfun "(cl_narg narg")) - (progn - (wt-nl1 "cl_object " cfun "(cl_narg narg") - (wt-h "cl_object " cfun "(cl_narg narg"))) - (do ((vl requireds (cdr vl)) - (lcl (1+ *lcl*) (1+ lcl))) - ((endp vl)) - (declare (fixnum lcl)) - (wt ", cl_object ") (wt-lcl lcl) - (wt-h1 ", cl_object")) - (when va_args - (wt ", ...") - (wt-h1 ", ...")) - (wt ")") - (wt-h1 ");") - - (wt-nl1 "{") - (wt-function-prolog sp) - (c2lambda-expr lambda-list (c1form-arg 2 lambda-expr) cfun fname) - (wt-nl1 "}") - (wt-function-epilogue))))) + (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)" cfun ");"))))) (defun wt-function-prolog (&optional sp local-entry) (wt " VT" *reservation-cmacro* @@ -509,50 +359,6 @@ (LONG-FLOAT "double ") (otherwise "cl_object "))) -(defun t1defmacro (args) - (check-args-number 'DEFMACRO args 2) - (cmpck (not (symbolp (car args))) - "The macro name ~s is not a symbol." (car args)) - (cmp-eval (cons 'DEFMACRO args)) - (let (macro-lambda (cfun (next-cfun)) (doc nil) (ppn nil)) - (setq macro-lambda (c1dm (car args) (second args) (cddr args))) - (when (second macro-lambda) (setq ppn (add-object (second macro-lambda)))) - (when (and (setq doc (car macro-lambda)) - (setq doc (si::expand-set-documentation (car args) 'function doc))) - (t1expr `(progn ,@doc))) - (add-load-time-values) - (make-c1form* 'DEFMACRO :args (car args) cfun (cddr macro-lambda) ppn - *special-binding*))) - -(defun t2defmacro (fname cfun macro-lambda ppn sp &aux (vv (add-symbol fname))) - (declare (ignore macro-lambda sp)) - (when (< *space* 3) - (when ppn - (wt-nl "si_put_sysprop(" vv "," (add-symbol 'si::pretty-print-format) "," ppn ");") - (wt-nl))) - (wt-h "static cl_object L" cfun "();") - (wt-nl "cl_def_c_macro(" vv ",L" cfun ");")) - -(defun t3defmacro (fname cfun macro-lambda ppn sp - &aux (*lcl* 0) (*temp* 0) (*max-temp* 0) - (*lex* *lex*) (*max-lex* *max-lex*) - (*env* *env*) (*max-env* 0) (*level* *level*) - (*volatile* - (if (get-sysprop fname 'CONTAINS-SETJMP) " volatile " "")) - (*exit* 'RETURN) (*unwind-exit* '(RETURN)) - (*destination* 'RETURN) - (*reservation-cmacro* (next-cmacro))) - (when *compile-print* (print-emitting fname)) - (wt-comment "macro definition for " fname) - (wt-nl1 "static cl_object L" cfun "(cl_object V1, cl_object V2)") - (wt-nl1 "{") - (wt-function-prolog sp) - (c2dm fname (car macro-lambda) (second macro-lambda) (third macro-lambda) - (fourth macro-lambda)) - (wt-nl1 "}") - (wt-function-epilogue) - ) - (defun t1ordinary (form) (when *compile-time-too* (cmp-eval form)) (setq form (c1expr form)) @@ -694,21 +500,35 @@ (t (cmperr "The C variable specification ~s is illegal." cvs)))) ) -(defun t3local-fun (closure-p fun lambda-expr - ;; if defined by labels can be tail-recursive - &aux (level (fun-level fun)) +(defun t3local-fun (fun &optional + &aux + (closure-p (fun-closure fun)) + (lambda-expr (fun-lambda fun)) + (level (fun-level fun)) + (cfun (fun-cfun fun)) (nenvs level) (*volatile* (c1form-volatile* lambda-expr)) + (*tail-recursion-info* fun) (lambda-list (c1form-arg 0 lambda-expr)) (requireds (car lambda-list)) (va_args (or (second lambda-list) (third lambda-list) (fourth lambda-list)))) (declare (fixnum level nenvs)) - (wt-comment (if (fun-closure fun) "closure " "local function ") + (when *compile-print* (print-emitting fun)) + (wt-comment (cond ((fun-global fun) "function definition for ") + ((fun-closure fun) "closure ") + (t "local function ")) (or (fun-name fun) (fun-description fun) 'CLOSURE)) - (wt-h "static cl_object LC" (fun-cfun fun) "(") - (wt-nl1 "static cl_object LC" (fun-cfun fun) "(") + (cond ((not (fun-global fun)) + (wt-h "static cl_object LC" cfun "(") + (wt-nl1 "static cl_object LC" cfun "(")) + ((stringp cfun) + (wt-h "cl_object " cfun "(") + (wt-nl1 "cl_object " cfun "(")) + (t + (wt-h "static cl_object L" cfun "(") + (wt-nl1 "static cl_object L" cfun "("))) (wt-h1 "cl_narg") (wt "cl_narg narg") (dotimes (n level) @@ -773,114 +593,6 @@ (wt-function-epilogue closure-p)) ; we should declare in CLSR only those used ) -;;; ---------------------------------------------------------------------- -;;; Function definition with in-line body expansion. -;;; This is similar to defentry, except that the C body is supplied -;;; instead of a C function to call. -;;; Besides, Lisp types are used instead of C types, for proper coersion. -;;; -;;; (defCbody logand (fixnum fixnum) fixnum "(#0) & (#1)") -;;; -;;; ---------------------------------------------------------------------- - -(defun t1defCbody (args &aux fun (cfun (next-cfun))) - (check-args-number 'DEFCBODY args 4) - (setq fun (first args)) - (cmpck (not (symbolp fun)) - "The function name ~s is not a symbol." fun) - (push (list fun cfun) *global-funs*) - (make-c1form* 'DEFCBODY :args fun cfun (second args) (third args) (fourth args))) - -(defun t2defCbody (fname cfun arg-types type body - &aux (vv (add-symbol fname))) - (declare (ignore arg-types type body)) - (wt-h "static cl_object L" cfun "();") - (wt-nl "cl_def_c_function_va(" vv ",(cl_objectfn)L" cfun ");") - ) - -(eval-when (compile eval) ; also in cmpinline.lsp - ;; by mds@sepgifbr.sep.de.edf.fr (M.Decugis) - (defmacro parse-index (fun i) - `(multiple-value-bind (a-read endpos) - (parse-integer ,fun :start (1+ ,i) :junk-allowed t) - (setq ,i (1- endpos)) - a-read)) - ) - -(defun t3defCbody (fname cfun arg-types type body) - (when *compile-print* (print-emitting fname)) - (wt-comment "function definition for " fname) - (wt-nl1 "static cl_object L" cfun "(cl_narg narg") - (do ((vl arg-types (cdr vl)) - (lcl 1 (1+ lcl))) - ((endp vl)) - (declare (fixnum lcl)) - (wt ", cl_object ") (wt-lcl lcl) - ) - (wt ")") - (wt-nl1 "{") - (flet ((lisp2c-type (type) - (case type - ((NIL) 'VOID) - (CHARACTER 'CHAR) - (FIXNUM 'CL_FIXNUM) - (LONG-FLOAT 'DOUBLE) - (SHORT-FLOAT 'FLOAT) - (otherwise 'OBJECT))) - (lisp2c-convert (type) - (case type - ((NIL) "(void)(V~d)") - (CHARACTER "object_to_char(V~d)") - (FIXNUM "object_to_fixnum(V~d)") - (LONG-FLOAT "object_to_double(V~d)") - (SHORT-FLOAT "object_to_float(V~d)") - (otherwise "V~d"))) - (wt-inline-arg (fun locs &aux (i 0)) - (declare (fixnum i)) - (cond ((stringp fun) - (when (char= (char (the string fun) 0) #\@) - (setq i 1) - (do () - ((char= (char (the string fun) i) #\;) (incf i)) - (incf i))) - (do ((size (length (the string fun)))) - ((>= i size)) - (declare (fixnum size)) - (let ((char (char (the string fun) i))) - (declare (character char)) - (if (char= char #\#) - (wt (nth (parse-index fun i) locs)) - (princ char *compiler-output1*)) - (incf i))))))) - (when type - (let ((ctype (lisp2c-type type))) - (if (eq ctype 'OBJECT) - (wt-nl "cl_object x;") - (wt-nl (string-downcase ctype) " x;")))) - (when (safe-compile) (wt-nl "check_arg(" (length arg-types) ");")) - (when type (wt-nl "x=")) - (wt-inline-arg - body - (do ((types arg-types (cdr types)) - (i 1 (1+ i)) - (lst)) - ((null types) (nreverse lst)) - (declare (object types) (fixnum i)) - (push (format nil (lisp2c-convert (car types)) i) lst))) - (wt ";") - (wt-nl "NVALUES=1;") - (wt-nl "return ") - (case type - ((NIL) (wt "Cnil")) - (BOOLEAN (wt "(x?Ct:Cnil)")) - (CHARACTER (wt "CODE_CHAR(x)")) - (FIXNUM (wt "MAKE_FIXNUM(x)")) - (SHORT-FLOAT (wt "make_shortfloat(x)")) - (LONG-FLOAT (wt "make_longfloat(x)")) - (otherwise (wt "x")) - ) - (wt ";}") - )) (defun t2function-constant (funob fun) (let ((previous (new-local *level* fun funob))) (if (and previous (fun-var previous)) @@ -890,6 +602,44 @@ (setf (fun-var fun) loc)))) ) +;;; ---------------------------------------------------------------------- +;;; Optimizer for FSET. Should remove the need for a special handling of +;;; DEFUN as a toplevel form. +;;; +(defun c1fset (args) + (destructuring-bind (fname def &optional (macro nil) (pprint nil)) + args + (let* ((fun (c1expr def))) + (cond ((and (eq (c1form-name fun) 'FUNCTION) + ;; When a function is 'CONSTANT, it is not a closure! + (eq (c1form-arg 0 fun) 'CONSTANT) + (typep macro 'boolean) + (typep pprint '(or integer null))) + ;; We need no function constant + (pop *top-level-forms*) + (make-c1form* 'SI:FSET :args + (c1expr fname) + (c1form-arg 1 fun) ;; Lambda form + (c1form-arg 2 fun) ;; Function object + macro + pprint)) + (t + (c1call-global 'SI:FSET (list fname def macro pprint))))))) + +(defun c2fset (fname funob fun macro pprint) + (let* ((*inline-blocks* 0) + (fname (first (coerce-locs (inline-args (list fname))))) + (cfun (fun-cfun fun))) + ;; FIXME! Look at c2function! + (new-local 0 fun funob) + (cond (macro + (wt-nl "cl_def_c_macro(" fname ",LC" cfun ",-1);")) + ((stringp cfun) + (wt-nl "cl_def_c_function_va(" fname "," cfun ");")) + (t + (wt-nl "cl_def_c_function_va(" fname ",LC" cfun ");"))) + (close-inline-blocks))) + ;;; ---------------------------------------------------------------------- ;;; Pass 1 top-levels. @@ -898,7 +648,6 @@ (put-sysprop 'EVAL-WHEN 'T1 #'t1eval-when) (put-sysprop 'PROGN 'T1 #'t1progn) (put-sysprop 'DEFUN 'T1 #'t1defun) -(put-sysprop 'DEFMACRO 'T1 #'t1defmacro) (put-sysprop 'DEFVAR 'T1 #'t1defvar) (put-sysprop 'MACROLET 'T1 #'t1macrolet) (put-sysprop 'LOCALLY 'T1 #'t1locally) @@ -910,13 +659,13 @@ (put-sysprop 'DEFCBODY 'T1 't1defCbody) ; Beppe ;(put-sysprop 'DEFUNC 'T1 't1defunC) ; Beppe (put-sysprop 'LOAD-TIME-VALUE 'C1 'c1load-time-value) +(put-sysprop 'SI:FSET 'C1 'c1fset) ;;; Pass 2 initializers. (put-sysprop 'DECL-BODY 't2 #'t2decl-body) (put-sysprop 'PROGN 'T2 #'t2progn) (put-sysprop 'DEFUN 'T2 #'t2defun) -(put-sysprop 'DEFMACRO 'T2 #'t2defmacro) (put-sysprop 'ORDINARY 'T2 #'t2ordinary) (put-sysprop 'DECLARE 'T2 #'t2declare) (put-sysprop 'DEFVAR 'T2 #'t2defvar) @@ -925,13 +674,12 @@ ;(put-sysprop 'DEFUNC 'T2 't2defunC); Beppe (put-sysprop 'FUNCTION-CONSTANT 'T2 't2function-constant); Beppe (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 'DEFUN 'T3 #'t3defun) -(put-sysprop 'DEFMACRO 'T3 #'t3defmacro) (put-sysprop 'CLINES 'T3 't3clines) (put-sysprop 'DEFCFUN 'T3 't3defcfun) ;(put-sysprop 'DEFENTRY 'T3 't3defentry) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 574824506..1700cd66e 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -71,8 +71,12 @@ (format t "~&;;; Compiling ~s.~%" *current-form*))) nil) -(defun print-emitting (name) - (format t "~&;;; Emitting code for ~s.~%" (or name "lambda"))) +(defun print-emitting (f) + (let* ((name (fun-name f))) + (unless name + (setf name (fun-description f))) + (when name + (format t "~&;;; Emitting code for ~s.~%" name)))) (defun undefined-variable (sym &aux (*print-case* :upcase)) (print-current-form) diff --git a/src/h/external.h b/src/h/external.h index e013ba0d5..ac98dbae2 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -308,7 +308,7 @@ extern cl_object cl_make_cfun(cl_object (*self)(), cl_object name, cl_object blo extern cl_object cl_make_cfun_va(cl_object (*self)(cl_narg narg,...), cl_object name, cl_object block); extern cl_object cl_make_cclosure_va(cl_object (*self)(cl_narg narg,...), cl_object env, cl_object block); extern void cl_def_c_function(cl_object sym, cl_object (*self)(), int narg); -extern void cl_def_c_macro(cl_object sym, cl_object (*self)(cl_object, cl_object)); +extern void cl_def_c_macro(cl_object sym, cl_object (*self)(), int narg); extern void cl_def_c_function_va(cl_object sym, cl_object (*self)(cl_narg narg,...)); diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index d0f1a63f1..3d6c53413 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -59,7 +59,7 @@ macro useful for defining macros." (when *dump-defun-definitions* (print function) (setq function `(si::bc-disassemble ,function))) - `(progn + `(eval-when (:compile-toplevel :load-toplevel :execute) (si::fset ',name ,function t ,pprint) ,@(si::expand-set-documentation name 'function doc-string) ',name))))