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