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

Add a name mangler to the lisp runtime. Use this mangler in the compiler to

Browse source 
optimize access to symbols and functions which are defined in the C runtime.
This commit is contained in:
jjgarcia 2001-07-05 10:08:52 +00:00
parent 0dc4df6002
commit f2da18a591
27 changed files with 783 additions and 709 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/cmp/cmpbind.lsp
View file

@ -85,7 +85,7 @@
(push 'BDS-BIND *unwind-exit*))))
(defun bds-bind (loc var)
(wt-nl "bds_bind(VV[" (var-loc var) "]," loc ");")
(wt-nl "bds_bind(" (var-loc var) "," loc ");")
;; push BDS-BIND only once:
;; bds-bind may be called several times on the same variable, e.g.
;; an optional has two alternative bindings.

12
src/cmp/cmpcall.lsp
View file

@ -279,8 +279,8 @@
(assoc (third funob) *global-funs*)))
(let ((temp (list 'TEMP (next-temp))))
(if *safe-compile*
(wt-nl temp "=symbol_function(VV[" (add-symbol (third funob)) "]);")
(wt-nl temp "=VV[" (add-symbol (third funob)) "]->symbol.gfdef;"))
(wt-nl temp "=symbol_function(" (add-symbol (third funob)) ");")
(wt-nl temp "=" (add-symbol (third funob)) "->symbol.gfdef;"))
temp)))
(ORDINARY (let* ((temp (list 'TEMP (next-temp)))
(*destination* temp))
@ -318,10 +318,10 @@
(unless loc
(setq loc
(if *compiler-push-events*
`(VV ,(add-symbol fname))
(format nil (if *safe-compile*
"symbol_function(VV[~d])"
"VV[~d]->symbol.gfdef") (add-symbol fname)))))
(add-symbol fname)
(format nil
(if *safe-compile* "symbol_function(~A)" "~A->symbol.gfdef")
(add-symbol fname)))))
(unwind-exit
(if (eq args 'ARGS-PUSHED)
(list 'CALL "apply" narg (list loc "&VALUES(0)") fname)

38
src/cmp/cmpenv.lsp
View file

@ -62,23 +62,16 @@
(setq *max-env* (max *env* *max-env*))))
(defun add-symbol (symbol)
(let ((x (assoc symbol *objects*)))
(cond (x (second x))
(t (incf *next-vv*)
(push (list symbol *next-vv*) *objects*)
(wt-data symbol)
*next-vv*))))
(add-object symbol))
(defun add-keyword (symbol)
(let ((x (assoc symbol *objects*)))
(cond (x (wt-filtered-data (format nil "#!~d" (- (1+ (second x)))))
(incf *next-vv*))
(t (incf *next-vv*)
(push (list symbol *next-vv*) *objects*)
(wt-data symbol)
*next-vv*))))
(defun add-keyword (symbol &aux x)
(incf *next-vv*)
(setq x (format nil "VV[~d]" *next-vv*))
(push (list symbol x) *objects*)
(wt-data symbol)
x)
(defun add-object (object &aux x)
(defun add-object (object &aux x found)
;;; Used only during Pass 1.
(cond ((sys:contains-sharp-comma object)
;;; SYS:CONTAINS-SHARP-COMMA returns T iff OBJECT
@ -86,13 +79,17 @@
(incf *next-vv*)
(push *next-vv* *sharp-commas*)
(wt-data (prin1-to-string object))
*next-vv*)
(format nil "VV[~d]" *next-vv*))
((setq x (assoc object *objects*))
(second x))
((and (symbolp object)
(multiple-value-setq (found x) (si::mangle-name object)))
x)
(t (incf *next-vv*)
(push (list object *next-vv*) *objects*)
(setq x (format nil "VV[~d]" *next-vv*))
(push (list object x) *objects*)
(wt-data object)
*next-vv*)))
x)))
(defun add-constant (symbol &aux x)
;;; Used only during Pass 1.
@ -101,8 +98,9 @@
(t (incf *next-vv*)
(push *next-vv* *sharp-commas*)
(wt-data (prin1-to-string (cons 'sys:|#,| symbol)))
(push (list symbol *next-vv*) *constants*)
*next-vv*)))
(setq x (format nil "VV[~d]" *next-vv*))
(push (list symbol x) *constants*)
x)))
(defun function-arg-types (arg-types &aux (types nil))
(do ((al arg-types (cdr al)))

4
src/cmp/cmpeval.lsp
View file

@ -282,7 +282,7 @@
(defun wt-structure-ref (loc name-vv index)
(if *safe-compile*
(wt "structure_ref(" loc ",VV[" name-vv "]," index ")")
(wt "structure_ref(" loc "," name-vv "," index ")")
#+clos
(wt "(" loc ")->instance.slots[" index "]")
#-clos
@ -329,7 +329,7 @@
(setq x (second (first locs)))
(setq y (second (second locs)))
(if *safe-compile*
(wt-nl "structure_set(" x ",VV[" name-vv "]," index "," y ");")
(wt-nl "structure_set(" x "," name-vv "," index "," y ");")
#+clos
(wt-nl "(" x ")->instance.slots[" index "]= " y ";")
#-clos

6
src/cmp/cmpfun.lsp
View file

@ -40,12 +40,12 @@
(cond ((characterp string)
(wt-nl "princ_char(" (char-code string))
(if (null vv-index) (wt ",Cnil")
(wt ",symbol_value(VV[" vv-index "])"))
(wt ",symbol_value(" vv-index ")"))
(wt ");"))
((= (length string) 1)
(wt-nl "princ_char(" (char-code (aref string 0)))
(if (null vv-index) (wt ",Cnil")
(wt ",symbol_value(VV[" vv-index "])"))
(wt ",symbol_value(" vv-index ")"))
(wt ");"))
(t
(wt-nl "princ_str(\"")
@ -58,7 +58,7 @@
(t (wt char)))))
(wt "\",")
(if (null vv-index) (wt "Cnil")
(wt "symbol_value(VV[" vv-index "])"))
(wt "symbol_value(" vv-index ")"))
(wt ");")))
(unwind-exit nil))
((eql string #\Newline) (c2call-global 'TERPRI (list stream) nil t))

10
src/cmp/cmplam.lsp
View file

@ -595,7 +595,7 @@
(wt-nl " CAR(p)=") (wt-va_arg call-lambda) (wt ";i++;}")
(bind rest-loc rest))
(wt-h "#define L" cfun "keys (&VV[" (add-keyword (caar keywords)) "])")
(wt-h "#define L" cfun "keys (&" (add-keyword (caar keywords)) ")")
(dolist (kwd (rest keywords))
(add-keyword (first kwd)))
@ -892,7 +892,7 @@
(declare (object reqs))
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "if(endp(") (wt-lcl lcl)
(wt "))FEinvalid_macro_call(VV[" (add-symbol name) "]);"))
(wt "))FEinvalid_macro_call(" (add-symbol name) ");"))
(dm-bind-loc (car reqs) `(CAR ,lcl))
(when (or (cdr reqs) optionals rest key-flag
*safe-compile* *compiler-check-args*)
@ -922,7 +922,7 @@
(wt-nl "{cl_object " loc1 ";")
(dolist (kwd keywords)
(wt-nl loc1 "=getf(") (wt-lcl lcl)
(wt ",VV[" (add-symbol (car kwd)) "],OBJNULL);")
(wt "," (add-symbol (car kwd)) ",OBJNULL);")
(wt-nl "if(" loc1 "==OBJNULL){")
(let ((*env* *env*)
(*unwind-exit* *unwind-exit*))
@ -937,13 +937,13 @@
(null rest)
(null key-flag))
(wt-nl "if(!endp(") (wt-lcl lcl)
(wt "))FEinvalid_macro_call(VV[" (add-symbol name) "]);"))
(wt "))FEinvalid_macro_call(" (add-symbol name) ");"))
(when (and (or *safe-compile* *compiler-check-args*)
key-flag
(not allow-other-keys))
(wt-nl "check_other_key(") (wt-lcl lcl) (wt "," (length keywords))
(dolist (kwd keywords)
(wt ",VV[" (add-symbol (car kwd)) "]"))
(wt "," (add-symbol (car kwd))))
(wt ");"))
(dolist (aux auxs)
(dm-bind-init aux)))

7
src/cmp/cmploc.lsp
View file

@ -127,7 +127,10 @@
(defun wt-lcl (lcl) (wt "V" lcl))
(defun wt-vv (vv) (wt "VV[" vv "]"))
(defun wt-vv (vv)
(if (numberp vv)
(wt "VV[" vv "]")
(wt vv)))
(defun wt-lcl-loc (lcl)
(wt-lcl lcl))
@ -138,7 +141,7 @@
(defun wt-number (value &optional vv)
(typecase value
(fixnum (wt "MAKE_FIXNUM(" value ")"))
(t (wt "VV[" vv "]"))))
(t (wt vv))))
(defun wt-character (value &optional vv)
(wt (format nil "code_char('\\~O')" value)))

15
src/cmp/cmpmain.lsp
View file

@ -235,7 +235,6 @@ Cannot compile ~a."
(format t "~&;;; Calling the C compiler... "))
(compiler-cc c-pathname o-pathname)
(cond ((probe-file o-pathname)
;(cat-data-file o-pathname data-pathname)
(when load (load o-pathname))
(when *compile-verbose*
(print-compiler-info)
@ -247,7 +246,6 @@ Cannot compile ~a."
(pathname-name o-pathname))))
(si:system (format nil "mv ~A ~A" (namestring ob-name)
(namestring o-pathname)))
;(cat-data-file o-pathname data-pathname)
(when load (load o-pathname))
(when *compile-verbose*
(print-compiler-info)
@ -368,7 +366,6 @@ Cannot compile ~a."
(delete-file c-pathname)
(delete-file h-pathname)
(cond ((probe-file o-pathname)
;(cat-data-file o-pathname data-pathname)
(load o-pathname :verbose nil)
(when *compile-verbose* (print-compiler-info))
(delete-file o-pathname)
@ -484,18 +481,6 @@ Cannot compile ~a."
; (namestring s-pathname))
))
(defun cat-data-file (o-pathname data-pathname)
(with-open-file (o-file (namestring o-pathname)
:direction :output
:if-exists :append)
;; cat data-file >> o-file
(with-open-file (data-file (namestring data-pathname))
(do ((buffer (make-string 256))
(n 0))
((zerop (setq n (sys::read-bytes data-file buffer 0 256))))
(declare (fixnum n))
(sys::write-bytes o-file buffer 0 n)))))
(defun print-compiler-info ()
(format t "~&;;; OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"
(cond ((null *compiler-check-args*) 0)

4
src/cmp/cmpspecial.lsp
View file

@ -164,8 +164,8 @@
(defun wt-symbol-function (vv)
(if *safe-compile*
(wt "symbol_function(VV[" vv "])")
(wt "(VV[" vv "]->symbol.gfdef)")))
(wt "symbol_function(" vv ")")
(wt "(" vv "->symbol.gfdef)")))
(defun wt-make-closure (fun &aux (cfun (fun-cfun fun)))
(declare (type fun fun))

4
src/cmp/cmptag.lsp
View file

@ -147,7 +147,7 @@
(when (and (tag-p tag) (plusp (tag-ref tag)))
(setf (tag-label tag) (next-label))
(setf (tag-unwind-exit tag) label)
(wt-nl "if (eql(nlj_tag,VV[" (add-symbol (tag-name tag)) "])) ")
(wt-nl "if (eql(nlj_tag," (add-symbol (tag-name tag)) ")) ")
(wt-go (tag-label tag))))
(when (var-ref-ccb tag-loc)
(wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);"))
@ -214,7 +214,7 @@
(defun c2go (tag nonlocal &aux (var (tag-var tag)))
(if nonlocal
(wt-nl "go(" var ",VV[" (add-symbol (tag-name tag)) "]);")
(wt-nl "go(" var "," (add-symbol (tag-name tag)) ");")
;; local go
(progn
(unwind-no-exit (tag-unwind-exit tag))

74
src/cmp/cmptop.lsp
View file

@ -140,7 +140,7 @@
(dolist (x *linking-calls*)
(let ((i (second x)))
(wt-nl1 "static cl_object LKF" i
"(int narg, ...) {TRAMPOLINK(VV[" (third x) "],&LK" i ");}")))
"(int narg, ...) {TRAMPOLINK(" (third x) ",&LK" i ");}")))
(wt-h "#define compiler_data_text_size " *wt-string-size*)
(wt-nl1 "static const char *compiler_data_text = ")
@ -279,8 +279,8 @@
(defun wt-if-proclaimed (fname cfun vv lambda-expr)
(when (fast-link-proclaimed-type-p fname)
(if (assoc fname *inline-functions*)
(wt-nl "(void)putprop(VV[" vv "],make_fixnum((int)LI"
cfun "),VV[" (add-object 'SYS::CDEFN)"]);")
(wt-nl "(void)putprop(" vv ",make_fixnum((int)LI"
cfun ")," (add-object 'SYS::CDEFN) ");")
(let ((arg-c (length (car (third lambda-expr))))
(arg-p (length (get fname 'PROCLAIMED-ARG-TYPES))))
(if (= arg-c arg-p)
@ -306,15 +306,12 @@
(nkey (length (fifth (third lambda-expr)))))
(declare (ignore sp funarg-vars))
(when (get fname 'NO-GLOBAL-ENTRY) (return-from t2defun nil))
(wt-nl "MF(VV[" vv "],L" cfun ",Cblock);")
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
(when (< *space* 3)
(when doc
(wt-nl "(void)putprop(VV[" vv "],VV[" doc "],VV["
(add-symbol 'si::function-documentation) "]);")
(wt-nl))
(setf (get fname 'DEBUG-PROP) t)
(wt-nl "(void)putprop(VV[" vv "],VV[Vdeb" vv "],VV["
(add-object 'ARGLIST) "]);"))
(wt-nl "(void)putprop(" vv "," doc ","
(add-symbol 'si::function-documentation) ");")
(wt-nl)))
(when (get fname 'PROCLAIMED-FUNCTION)
(wt-if-proclaimed fname cfun vv lambda-expr))
)
@ -417,9 +414,7 @@
(wt-function-prolog sp)
(c2lambda-expr lambda-list (third (cddr lambda-expr)) cfun fname)
(wt-nl1 "}")
(wt-function-epilogue))))
(add-debug-info fname lambda-expr) ; needed also when code is shared
)
(wt-function-epilogue)))))
(defun wt-function-prolog (&optional sp local-entry)
(wt " VT" *reservation-cmacro*
@ -459,24 +454,6 @@
(wt-h1 ";"))
)
;;; Modified for debugging compiled functions. Beppe
(defun add-debug-info (fname lambda-expr)
(cond
((>= *space* 3))
((null (get fname 'DEBUG-PROP))
(warn "~a has a duplicate definition in this file" fname))
(t
(remprop fname 'DEBUG-PROP)
(let* ((args (third lambda-expr))
(requireds (mapcar #'var-name (first args)))
(optionals (mapcar #'(lambda (x) (var-name (car x)))
(second args)))
;; (rest (var-name (third args)))
(keywords (mapcar #'(lambda (x) (var-name (second x))) (fifth args)))
)
(wt-h "#define Vdeb" (add-symbol fname) " "
(add-object (nconc requireds optionals keywords)))))))
;;; Checks the register slots of variables, and finds which
;;; variables should be in registers, reducing the var-ref value
;;; in the remaining. Data and address variables are done separately.
@ -582,15 +559,14 @@
(declare (ignore macro-lambda sp))
(when (< *space* 3)
(when doc
(wt-nl "(void)putprop(VV[" vv "],VV[" doc "],VV["
(add-symbol 'si::function-documentation) "]);")
(wt-nl "(void)putprop(" vv "," doc ","
(add-symbol 'si::function-documentation) ");")
(wt-nl))
(when ppn
(wt-nl "(void)putprop(VV[" vv "],VV[" ppn "],siSpretty_print_format);")
(wt-nl "(void)putprop(" vv "," ppn ",siSpretty_print_format);")
(wt-nl)))
(wt-h "static cl_object L" cfun "();")
(wt-nl "MM(VV[" vv "],L" cfun ",Cblock);")
)
(wt-nl "MM(" vv ",L" cfun ",Cblock);"))
(defun t3defmacro (fname cfun macro-lambda doc ppn sp
&aux (*lcl* 0) (*temp* 0) (*max-temp* 0)
@ -640,7 +616,7 @@
(wt-nl "VV[" vv "]=string_to_object(VV[" vv "]);"))
(defun t2declare (vv)
(wt-nl "VV[" vv "]->symbol.stype=(short)stp_special;"))
(wt-nl vv "->symbol.stype=(short)stp_special;"))
(defun t1defvar (args &aux form (doc nil) (name (car args)))
(when *compile-time-too* (cmp-eval `(defvar ,@args)))
@ -659,15 +635,15 @@
)
(defun t2defvar (var form doc &aux (vv (var-loc var)))
(wt-nl "VV[" vv "]->symbol.stype=(short)stp_special;")
(wt-nl vv "->symbol.stype=(short)stp_special;")
(let* ((*exit* (next-label)) (*unwind-exit* (list *exit*))
(*destination* (list 'VAR var)))
(wt-nl "if(VV[" vv "]->symbol.dbind == OBJNULL){")
(wt-nl "if(" vv "->symbol.dbind == OBJNULL){")
(c2expr form)
(wt "}")
(wt-label *exit*))
(when (and doc (< *space* 3))
(wt-nl "(void)putprop(VV[" vv "],VV[" doc "],VV[" (add-symbol 'si::variable-documentation) "]);")
(wt-nl "(void)putprop(" vv "," doc "," (add-symbol 'si::variable-documentation) ");")
(wt-nl))
)
@ -822,19 +798,19 @@
((eq (caar s) 'QUOTE)
(wt-nl1 (cadadr s))
(if (eq (caadr s) 'OBJECT)
(wt "=VV[" (cadar s) "];")
(wt "=" (cadar s) ";")
(wt "=object_to_" (string-downcase (symbol-name (caadr s)))
"(VV[" (cadar s) "]);")))
"(" (cadar s) ");")))
(t
(setq narg (length cdar s))
(cond ((setq fd (assoc (caar s) *global-funs*))
(cond (*compiler-push-events*
(wt-nl1 "ihs_push(VV[" (add-symbol (caar s)) "],&narg);")
(wt-nl1 "ihs_push(" (add-symbol (caar s)) ",&narg);")
(wt-nl1 "L" (cdr fd) "();")
(wt-nl1 "ihs_pop();"))
(t (wt-nl1 "L" (cdr fd) "(" narg))))
(t (wt-nl1 "funcall(" (1+ narg) ",VV[" (add-symbol (caar s))
"]->symbol.gfdef"))
(t (wt-nl1 "funcall(" (1+ narg) "," (add-symbol (caar s))
"->symbol.gfdef"))
)
(dolist (arg (cdar s))
(wt ",")
@ -900,7 +876,7 @@
&aux (vv (add-symbol fname)))
(declare (ignore arg-types type cname))
(wt-h "static L" cfun "();")
(wt-nl "MF(VV[" vv "],L" cfun ",Cblock);")
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
)
(defun t3defentry (fname cfun arg-types type cname)
@ -980,7 +956,7 @@
&aux (vv (add-symbol fname)))
(declare (ignore arg-types type body))
(wt-h "static cl_object L" cfun "();")
(wt-nl "MF(VV[" vv "],L" cfun ",Cblock);")
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
)
#|
@ -1115,7 +1091,7 @@
&aux (vv (add-symbol fname)))
(declare (ignore lambda-list body))
(wt-h "static L" cfun "();")
(wt-nl "MF(VV[" vv "],L" cfun ",Cblock);")
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
)
(defun t3defunC (fname cfun lambda-list body)
@ -1175,7 +1151,7 @@
(wt-nl "parse_key(vs_base+" (+ nreq nopt) ",FALSE,"
(if allow-other-keys "TRUE," "FALSE,") (length keywords))
(dolist (k keywords)
(wt-nl ",VV[" (add-object (car k)) "]"))
(wt-nl "," (add-object (car k))))
(wt ");")
(do ((ks keywords (cdr ks))
(i (+ nreq nopt) (1+ i)))

16
src/cmp/cmpvar.lsp
View file

@ -63,9 +63,9 @@
(when x
(dolist (tlf *top-level-forms*)
(when (or (and (eq (car tlf) 'DEFVAR)
(= (var-loc (second tlf)) (second x)))
(equalp (var-loc (second tlf)) (second x)))
(and (eq (car tlf) 'DECLARE)
(= (second tlf) (second x))))
(equalp (second tlf) (second x))))
(return tlf))))))
;;;
@ -220,11 +220,11 @@
(LEXICAL (cond ;(ccb (wt-env var-loc))
((var-ref-ccb var) (wt-env var-loc))
(t (wt-lex var-loc))))
(SPECIAL (wt "(VV[" var-loc "]->symbol.dbind)"))
(SPECIAL (wt "(" var-loc "->symbol.dbind)"))
(REPLACED (wt var-loc))
(GLOBAL (if *safe-compile*
(wt "symbol_value(VV[" var-loc "])")
(wt "(VV[" var-loc "]->symbol.dbind)")))
(wt "symbol_value(" var-loc ")")
(wt "(" var-loc "->symbol.dbind)")))
(t (case (var-kind var)
(FIXNUM (wt "MAKE_FIXNUM"))
(CHARACTER (wt "code_char"))
@ -247,11 +247,11 @@
(wt-env var-loc)
(wt-lex var-loc))
(wt "= " loc ";"))
(SPECIAL (wt-nl "(VV[" var-loc "]->symbol.dbind)= " loc ";"))
(SPECIAL (wt-nl "(" var-loc "->symbol.dbind)= " loc ";"))
(GLOBAL
(if *safe-compile*
(wt-nl "set(VV[" var-loc "]," loc ");")
(wt-nl "(VV[" var-loc "]->symbol.dbind)= " loc ";")))
(wt-nl "set(" var-loc "," loc ");")
(wt-nl "(" var-loc "->symbol.dbind)= " loc ";")))
(t
(wt-nl) (wt-lcl var-loc) (wt "= ")
(case (var-kind var)

1046
src/cmp/sysfun.lsp
View file

File diff suppressed because it is too large Load diff