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

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.

Browse source
This commit is contained in:
jjgarcia 2004-05-05 08:38:07 +00:00
parent 959180c2bd
commit 4e3189eddd
21 changed files with 262 additions and 782 deletions
Download patch file Download diff file Expand all files Collapse all files

10
src/CHANGELOG
View file

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

6
src/c/cfun.d
View file

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

6
src/c/macros.d
View file

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

4
src/c/unixint.d
View file

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

8
src/cmp/cmpblock.lsp
View file

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

33
src/cmp/cmpcall.lsp
View file

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

14
src/cmp/cmpdefs.lsp
View file

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

11
src/cmp/cmpeval.lsp
View file

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

17
src/cmp/cmpexit.lsp
View file

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

118
src/cmp/cmpflet.lsp
View file

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

328
src/cmp/cmplam.lsp
View file

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

8
src/cmp/cmplet.lsp
View file

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

2
src/cmp/cmpmac.lsp
View file

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

8
src/cmp/cmpmain.lsp
View file

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

1
src/cmp/cmpmulti.lsp
View file

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

20
src/cmp/cmpspecial.lsp
View file

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

4
src/cmp/cmptag.lsp
View file

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

434
src/cmp/cmptop.lsp
View file

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

8
src/cmp/cmputil.lsp
View file

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

2
src/h/external.h
View file

@ -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,...));

2
src/lsp/evalmacros.lsp
View file

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