mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -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

48
src/c/all_functions.d
View file

@ -3,17 +3,11 @@
#include "ecls.h"
#include "page.h"
struct function_info {
const char *name;
cl_object (*f)(int, ...);
short type;
};
#define form 2
#define cl 0
#define si 1
static const struct function_info all_functions[] = {
const struct function_info all_functions[] = {
/* alloc.c */
@ -35,6 +29,10 @@ static const struct function_info all_functions[] = {
{"GC", clLgc, cl},
#endif
/* all_symbols.c */
{"MANGLE-NAME", siLmangle_name, si},
/* array.c */
{"MAKE-PURE-ARRAY", siLmake_pure_array, si},
@ -332,7 +330,7 @@ static const struct function_info all_functions[] = {
{"COPY-TREE", clLcopy_tree, cl},
{"REVAPPEND", clLrevappend, cl},
{"NCONC", clLnconc, cl},
{"NRECONC", clLreconc, cl},
{"NRECONC", clLnreconc, cl},
{"BUTLAST", clLbutlast, cl},
{"NBUTLAST", clLnbutlast, cl},
@ -410,7 +408,7 @@ static const struct function_info all_functions[] = {
{"ARGC", siLargc, si},
{"ARGV", siLargv, si},
{"GETENV", siLgetenv, si},
{"POINTER", siLaddress, si},
{"POINTER", siLpointer, si},
#if !defined(MSDOS) && !defined(__NeXT)
{"MACHINE-INSTANCE", clLmachine_instance, cl},
{"MACHINE-VERSION", clLmachine_version, cl},
@ -439,12 +437,12 @@ static const struct function_info all_functions[] = {
/* num-arith.c */
{"+", clLplus, cl},
{"-", clLminus, cl},
{"*", clLtimes, cl},
{"/", clLdivide, cl},
{"1+", clLone_plus, cl},
{"1-", clLone_minus, cl},
{"+", clLP, cl},
{"-", clLM, cl},
{"*", clLX, cl},
{"/", clLN, cl},
{"1+", clL1P, cl},
{"1-", clL1M, cl},
{"CONJUGATE", clLconjugate, cl},
{"GCD", clLgcd, cl},
{"LCM", clLlcm, cl},
@ -474,12 +472,12 @@ static const struct function_info all_functions[] = {
/* num_comp.c */
{"=", clLall_the_same, cl},
{"/=", clLall_different, cl},
{"<", clLmonotonically_increasing, cl},
{">", clLmonotonically_decreasing, cl},
{"<=", clLmonotonically_nondecreasing, cl},
{">=", clLmonotonically_nonincreasing, cl},
{"=", clLE, cl},
{"/=", clLNE, cl},
{"<", clLL, cl},
{">", clLG, cl},
{"<=", clLLE, cl},
{">=", clLGE, cl},
{"MAX", clLmax, cl},
{"MIN", clLmin, cl},
@ -627,7 +625,7 @@ static const struct function_info all_functions[] = {
{"WRITE-STRING", clLwrite_string, cl},
{"WRITE-LINE", clLwrite_line, cl},
{"WRITE-BYTE", clLwrite_byte, cl},
{"WRITE-BYTES", clLwrite_bytes, si},
{"WRITE-BYTES", siLwrite_bytes, si},
{"TERPRI", clLterpri, cl},
{"FRESH-LINE", clLfresh_line, cl},
{"FINISH-OUTPUT", clLforce_output, cl},
@ -668,7 +666,7 @@ static const struct function_info all_functions[] = {
{"PARSE-INTEGER", clLparse_integer, cl},
{"READ-BYTE", clLread_byte, cl},
{"READ-BYTES", clLread_bytes, si},
{"READ-BYTES", siLread_bytes, si},
{"COPY-READTABLE", clLcopy_readtable, cl},
{"READTABLEP", clLreadtablep, cl},
@ -797,8 +795,8 @@ static const struct function_info all_functions[] = {
{"SLEEP", clLsleep, cl},
{"GET-INTERNAL-RUN-TIME", clLget_internal_run_time, cl},
{"GET-INTERNAL-REAL-TIME", clLget_internal_real_time, cl},
{"GET-LOCAL-TIME-ZONE", clLget_local_time_zone, si},
{"DAYLIGHT-SAVING-TIME-P", clLdaylight_saving_timep, si},
{"GET-LOCAL-TIME-ZONE", siLget_local_time_zone, si},
{"DAYLIGHT-SAVING-TIME-P", siLdaylight_saving_time_p, si},
/* toplevel.c */

106
src/c/all_symbols.d
View file

@ -38,7 +38,7 @@ const struct symbol_info all_symbols[] = {
#endif
/* compiler.c */
{&siSlambda_block, "LAMBDA-BLOCK", CL_ORDINARY},
{&clSlambda_block, "LAMBDA-BLOCK", CL_ORDINARY},
/* conditional.c */
{&clSotherwise, "OTHERWISE", CL_ORDINARY},
@ -310,6 +310,110 @@ const struct symbol_info all_symbols[] = {
{NULL, (const char*)NULL, CL_ORDINARY}};
@(defun si::mangle-name (symbol &optional as_symbol)
int l;
char c, *source, *dest;
cl_object output;
cl_object package;
cl_object found = Cnil;
bool is_symbol;
@
assert_type_symbol(symbol);
is_symbol = (as_symbol == Cnil);
if (is_symbol) {
if (symbol == Cnil)
@(return Ct make_simple_string("Cnil"))
else if (symbol == Ct)
@(return Ct make_simple_string("Ct"))
for (l = 0; all_symbols[l].loc != NULL; l++) {
if (symbol == *(all_symbols[l].loc)) {
found = Ct;
break;
}
}
} else {
cl_object fun;
fun = symbol->symbol.gfdef;
if (fun != OBJNULL && type_of(fun) == t_cfun) {
for (l = 0; all_functions[l].name != NULL; l++)
if (fun->cfun.entry == all_functions[l].f) {
if (fun->cfun.name != Cnil)
symbol = fun->cfun.name;
found = Ct;
break;
}
}
}
package= symbol->symbol.hpack;
symbol = symbol->symbol.name;
l = symbol->string.fillp;
source = symbol->string.self;
output = alloc_simple_string(l+1); array_allocself(output);
dest = output->string.self;
if (is_symbol && source[0] == '*') {
if (l > 2 && source[l-1] == '*') l--;
c = 'V';
l--;
source++;
} else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') {
c = 'C';
l-= 2;
source++;
} else if (!is_symbol) {
c = 'L';
} else if (package == keyword_package) {
c = 'K';
} else {
c = 'S';
}
if (package == lisp_package)
package = make_simple_string("cl");
else if (package == system_package)
package = make_simple_string("si");
else if (package == keyword_package)
package = Cnil;
else
package = lisp_package->pack.name;
*(dest++) = c;
output->string.fillp = 1;
while (l--) {
c = *(source++);
if (isalpha(c))
c = tolower(c);
else if (isnumber(c))
;
else if (c == '-' || c == '_') {
c = '_';
} else if (c == '&') {
c = 'A';
} else if (c == '*') {
c = 'X';
} else if (c == '+') {
c = 'P';
} else if (c == '<') {
c = 'L';
} else if (c == '>') {
c = 'G';
} else if (c == '=') {
c = 'E';
} else if (c == '/') {
c = 'N';
} else if (c == ':') {
c = 'X';
} else {
@(return Cnil Cnil)
}
*(dest++) = c;
output->string.fillp++;
}
if (dest[-1] == '_')
dest[-1] = 'M';
*(dest++) = '\0';
if (!Null(package))
output = @si::string-concatenate(2,package,output);
@(return found output)
@)
void
init_all_symbols(void) {
const struct symbol_info *s = all_symbols;

4
src/c/compiler.d
View file

@ -18,7 +18,7 @@
/********************* EXPORTS *********************/
cl_object @'si::lambda-block';
cl_object @'lambda-block';
cl_object @'declare';
cl_object @'defun';
cl_object @'compile', @'load', @'eval', @'progn', @'warn', @'typep', @'otherwise';
@ -906,7 +906,7 @@ c_function(cl_object args) {
} else if (CONSP(function) && CAR(function) == @'lambda') {
asm_op(OP_CLOSE);
asm1(make_lambda(Cnil, CDR(function)));
} else if (CONSP(function) && CAR(function) == @'si::lambda-block') {
} else if (CONSP(function) && CAR(function) == @'lambda-block') {
cl_object name = CADR(function);
cl_object body = CDDR(function);
asm_op(OP_CLOSE);

2
src/c/dpp.c
View file

@ -286,6 +286,8 @@ read_name(int is_symbol)
poolp--;
if (l > 2 && oneC && poolp[-1] == 'P')
poolp--;
if (poolp[-1] == '_')
poolp[-1] = 'M';
if (colon == NULL) {
char buf[256];
poolp[0] = buf[0] = '\0';

2
src/c/list.d
View file

@ -596,7 +596,7 @@ nconc(cl_object l, cl_object y)
return l;
}
@(defun reconc (l y)
@(defun nreconc (l y)
cl_object x, z;
@
/* INV: when a circular list is "reconc'ed", the pointer ends

2
src/c/main.d
View file

@ -153,7 +153,7 @@ main(int argc, char **argv)
@(return ((value == NULL)? Cnil : make_string_copy(value)))
@)
@(defun si::address (x)
@(defun si::pointer (x)
@
@(return MAKE_FIXNUM((int)x))
@)

12
src/c/num_arith.d
View file

@ -18,7 +18,7 @@
/* (* ) */
@(defun times (&rest nums)
@(defun * (&rest nums)
int i;
cl_object numi, prod = MAKE_FIXNUM(1);
@
@ -208,7 +208,7 @@ number_times(cl_object x, cl_object y)
}
/* (+ ) */
@(defun plus (&rest nums)
@(defun + (&rest nums)
int i;
cl_object numi, sum = MAKE_FIXNUM(0);
@
@ -363,7 +363,7 @@ number_plus(cl_object x, cl_object y)
}
/* (- ) */
@(defun minus (num &rest nums)
@(defun - (num &rest nums)
int i;
cl_object diff;
@
@ -586,7 +586,7 @@ number_negate(cl_object x)
}
/* (/ ) */
@(defun divide (num &rest nums)
@(defun / (num &rest nums)
int i;
@
/* INV: type check is in number_divide() */
@ -802,7 +802,7 @@ get_gcd(cl_object x, cl_object y)
}
/* (1+ x) */
@(defun one_plus (x)
@(defun 1+ (x)
@ /* INV: type check is in one_plus() */
@(return one_plus(x))
@)
@ -848,7 +848,7 @@ one_plus(cl_object x)
}
/* (1- x) */
@(defun one_minus (x)
@(defun 1- (x)
@ /* INV: type check is in one_minus() */
@(return one_minus(x))
@)

16
src/c/num_comp.d
View file

@ -23,7 +23,7 @@
*/
@(defun all_the_same (num &rest nums)
@(defun = (num &rest nums)
int i;
cl_object numi;
@
@ -259,7 +259,7 @@ number_compare(cl_object x, cl_object y)
}
}
@(defun all_different (&rest nums)
@(defun /= (&rest nums)
int i, j;
va_list numb;
@
@ -281,14 +281,10 @@ number_compare(cl_object x, cl_object y)
{ va_list nums; va_start(nums, narg); \
return monotonic(i, j, narg, (cl_object *)nums); }
cl_object
@monotonically-nondecreasing MONOTONIC( 1, 0)
cl_object
@monotonically-nonincreasing MONOTONIC(-1, 0)
cl_object
@monotonically-increasing MONOTONIC( 1, 1)
cl_object
@monotonically-decreasing MONOTONIC(-1, 1)
cl_object @<= MONOTONIC( 1, 0)
cl_object @>= MONOTONIC(-1, 0)
cl_object @< MONOTONIC( 1, 1)
cl_object @> MONOTONIC(-1, 1)
cl_object
monotonic(int s, int t, int narg, cl_object *nums)

4
src/c/pathname.d
View file

@ -983,7 +983,7 @@ coerce_to_from_pathname(cl_object x, cl_object host)
FEerror("~S is not a valid to-pathname translation", 1, from);
set = CONS(CONS(from, CONS(to, Cnil)), set);
}
CADR(pair) = @reconc(2, set, Cnil);
CADR(pair) = @nreconc(2, set, Cnil);
@(return set)
@)
@ -1101,7 +1101,7 @@ translate_pathname(cl_object source, cl_object from, cl_object to)
a = CDR(a);
b = CDR(b);
}
@reconc(2, wilds, Cnil);
@nreconc(2, wilds, Cnil);
if (a != Cnil || b != Cnil)
goto error;
for (c = Cnil, pc = &c, b = to->pathname.directory; !endp(b); b = CDR(b)) {

2
src/c/print.d
View file

@ -2063,7 +2063,7 @@ RETRY: if (type_of(strm) == t_stream) {
@(return integer)
@)
@(defun write_bytes (stream string start end)
@(defun si::write_bytes (stream string start end)
cl_index is, ie; FILE *fp;
int written, sofarwritten, towrite;
@

2
src/c/read.d
View file

@ -1947,7 +1947,7 @@ CANNOT_PARSE:
@(return MAKE_FIXNUM(c))
@)
@(defun read_bytes (stream string start end)
@(defun si::read_bytes (stream string start end)
int is, ie, c; FILE *fp;
@
assert_type_stream(stream);

4
src/c/time.d
View file

@ -95,7 +95,7 @@ UTC_time_to_universal_time(int i)
*
* Based on Lott's get_timezone() function from CMU Common Lisp.
*/
@(defun get_local_time_zone ()
@(defun si::get_local_time_zone ()
struct tm ltm, gtm;
int mw;
time_t when = 0L;
@ -118,7 +118,7 @@ UTC_time_to_universal_time(int i)
* defaults to current time.
*
*/
@(defun daylight_saving_timep (&rest args)
@(defun si::daylight-saving-time-p (&rest args)
struct tm *ltm;
time_t when;
@

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

43
src/h/lisp_external.h
View file

@ -28,6 +28,10 @@ extern cl_object clLgc _ARGS((int narg, cl_object area));
extern cl_object siLroom_report _ARGS((int narg));
#endif /* GBC_BOEHM */
/* all_symbols.c */
extern cl_object siLmangle_name _ARGS((int narg, cl_object symbol, ...));
/* array.c */
extern cl_object clLaref _ARGS((int narg, cl_object x, ...));
@ -135,7 +139,7 @@ extern cl_object siLspecialp _ARGS((int narg, cl_object sym));
/* compiler.c */
extern cl_object siSlambda_block;
extern cl_object clSlambda_block;
extern cl_object clSdeclare;
extern cl_object clScompile;
extern cl_object clSload;
@ -391,7 +395,7 @@ extern cl_object clLcopy_alist _ARGS((int narg, cl_object x));
extern cl_object clLcopy_tree _ARGS((int narg, cl_object x));
extern cl_object clLrevappend _ARGS((int narg, cl_object x, cl_object y));
extern cl_object clLnconc _ARGS((int narg, ...));
extern cl_object clLreconc _ARGS((int narg, cl_object x, cl_object y));
extern cl_object clLnreconc _ARGS((int narg, cl_object x, cl_object y));
extern cl_object clLbutlast _ARGS((int narg, cl_object lis, ...));
extern cl_object clLnbutlast _ARGS((int narg, cl_object lis, ...));
extern cl_object clLldiff _ARGS((int narg, cl_object x, cl_object y));
@ -481,7 +485,7 @@ extern cl_object clLquit _ARGS((int narg, ...));
extern cl_object siLargc _ARGS((int narg));
extern cl_object siLargv _ARGS((int narg, cl_object index));
extern cl_object siLgetenv _ARGS((int narg, cl_object var));
extern cl_object siLaddress _ARGS((int narg, cl_object x));
extern cl_object siLpointer _ARGS((int narg, cl_object x));
extern cl_object siLnani _ARGS((int narg, cl_object x));
extern cl_object clLidentity _ARGS((int narg, cl_object x));
extern cl_object clLmachine_instance _ARGS((int narg));
@ -505,14 +509,14 @@ extern cl_object clLvalues_list _ARGS((int narg, cl_object list));
/* num_arith.c */
extern cl_object clLtimes _ARGS((int narg, ...));
extern cl_object clLplus _ARGS((int narg, ...));
extern cl_object clLminus _ARGS((int narg, cl_object num, ...));
extern cl_object clLX _ARGS((int narg, ...));
extern cl_object clLP _ARGS((int narg, ...));
extern cl_object clLM _ARGS((int narg, cl_object num, ...));
extern cl_object clLconjugate _ARGS((int narg, cl_object c));
extern cl_object clLdivide _ARGS((int narg, cl_object num, ...));
extern cl_object clLN _ARGS((int narg, cl_object num, ...));
extern cl_object clLgcd _ARGS((int narg, ...));
extern cl_object clLone_plus _ARGS((int narg, cl_object x));
extern cl_object clLone_minus _ARGS((int narg, cl_object x));
extern cl_object clL1P _ARGS((int narg, cl_object x));
extern cl_object clL1M _ARGS((int narg, cl_object x));
extern cl_object clLlcm _ARGS((int narg, cl_object lcm, ...));
/* num_co.c */
@ -539,12 +543,12 @@ extern cl_object clLimagpart _ARGS((int narg, cl_object x));
/* num_comp.c */
extern cl_object clLall_the_same _ARGS((int narg, cl_object num, ...));
extern cl_object clLall_different _ARGS((int narg, ...));
extern cl_object clLmonotonically_nondecreasing _ARGS((int narg, ...));
extern cl_object clLmonotonically_nonincreasing _ARGS((int narg, ...));
extern cl_object clLmonotonically_increasing _ARGS((int narg, ...));
extern cl_object clLmonotonically_decreasing _ARGS((int narg, ...));
extern cl_object clLE _ARGS((int narg, cl_object num, ...));
extern cl_object clLNE _ARGS((int narg, ...));
extern cl_object clLL _ARGS((int narg, ...));
extern cl_object clLG _ARGS((int narg, ...));
extern cl_object clLGE _ARGS((int narg, ...));
extern cl_object clLLE _ARGS((int narg, ...));
extern cl_object clLmax _ARGS((int narg, cl_object max, ...));
extern cl_object clLmin _ARGS((int narg, cl_object min, ...));
@ -742,9 +746,10 @@ extern cl_object clLwrite_line _ARGS((int narg, cl_object strng, ...));
extern cl_object clLterpri _ARGS((int narg, ...));
extern cl_object clLfresh_line _ARGS((int narg, ...));
extern cl_object clLforce_output _ARGS((int narg, ...));
#define clLfinish_output clLforce_output
extern cl_object clLclear_output _ARGS((int narg, ...));
extern cl_object clLwrite_byte _ARGS((int narg, cl_object integer, cl_object binary_output_stream));
extern cl_object clLwrite_bytes _ARGS((int narg, cl_object stream, cl_object string, cl_object start, cl_object end));
extern cl_object siLwrite_bytes _ARGS((int narg, cl_object stream, cl_object string, cl_object start, cl_object end));
/* profile.c */
@ -779,7 +784,7 @@ extern cl_object clLread_char_no_hang _ARGS((int narg, ...));
extern cl_object clLclear_input _ARGS((int narg, ...));
extern cl_object clLparse_integer _ARGS((int narg, cl_object strng, ...));
extern cl_object clLread_byte _ARGS((int narg, cl_object binary_input_stream, ...));
extern cl_object clLread_bytes _ARGS((int narg, cl_object stream, cl_object string, cl_object start, cl_object end));
extern cl_object siLread_bytes _ARGS((int narg, cl_object stream, cl_object string, cl_object start, cl_object end));
extern cl_object clLcopy_readtable _ARGS((int narg, ...));
extern cl_object clLreadtablep _ARGS((int narg, cl_object readtable));
extern cl_object clLset_syntax_from_char _ARGS((int narg, cl_object tochr, cl_object fromchr, ...));
@ -922,8 +927,8 @@ extern cl_object clLget_universal_time _ARGS((int narg));
extern cl_object clLsleep _ARGS((int narg, cl_object z));
extern cl_object clLget_internal_run_time _ARGS((int narg));
extern cl_object clLget_internal_real_time _ARGS((int narg));
extern cl_object clLget_local_time_zone _ARGS((int narg));
extern cl_object clLdaylight_saving_timep _ARGS((int narg, ...));
extern cl_object siLget_local_time_zone _ARGS((int narg));
extern cl_object siLdaylight_saving_time_p _ARGS((int narg, ...));
/* typespec.c */

7
src/h/page.h
View file

@ -142,3 +142,10 @@ struct keyword_info {
extern const struct keyword_info all_keywords[];
struct function_info {
const char *name;
cl_object (*f)(int, ...);
short type;
};
extern const struct function_info all_functions[];