Commit c882e22b authored by jjgarcia's avatar jjgarcia

Speed improvements in the subtypep implementation, plus additional type...

Speed improvements in the subtypep implementation, plus additional type declarations to enforce inlining of CDR/CAR
parent d9d9680e
......@@ -99,6 +99,9 @@ ECL 0.9g
- The syntax of #\: can now be changed.
- Adjusting displaced bit-vectors failed to take the displace-offset into
account.
* ANSI compatibility:
- Several functions that signaled type-errors did not set the right values
......
......@@ -609,10 +609,17 @@ check_displaced(cl_object dlist, cl_object orig, cl_index newdim)
*/
void adjust_displaced(cl_object x, ptrdiff_t diff)
{
if (x->array.self.t != NULL)
x->array.self.t = (cl_object *)((char*)(x->array.self.t) + diff);
for (x = CDR(x->array.displaced); x != Cnil; x = CDR(x))
adjust_displaced(CAR(x), diff);
if (x->array.self.t != NULL) {
if (array_elttype(x) == aet_bit) {
ptrdiff_t aux = diff + x->array.offset;
x->array.offset = aux % CHAR_BIT;
x->array.self.bit += aux / CHAR_BIT;
} else {
x->array.self.t = (cl_object *)((char*)(x->array.self.t) + diff);
}
for (x = CDR(x->array.displaced); x != Cnil; x = CDR(x))
adjust_displaced(CAR(x), diff);
}
}
cl_elttype
......@@ -834,6 +841,9 @@ si_replace_array(cl_object olda, cl_object newa)
goto OUTPUT;
}
diff = (char*)(newa->array.self.t) - (char*)(olda->array.self.t);
if (array_elttype(newa) == aet_bit) {
diff = diff * CHAR_BIT + (newa->array.offset - olda->array.offset);
}
dlist = CDR(olda->array.displaced);
displaced = CONS(CAR(newa->array.displaced), dlist);
check_displaced(dlist, olda, newa->array.dim);
......
......@@ -48,12 +48,30 @@ test_compare_not(struct cl_test *t, cl_object x)
return (outcome == Cnil);
}
static bool
test_eq(struct cl_test *t, cl_object x)
{
return (t->item_compared == (t->key_c_function)(t, x));
}
static bool
test_eql(struct cl_test *t, cl_object x)
{
return eql(t->item_compared, (t->key_c_function)(t, x));
}
static bool
test_equal(struct cl_test *t, cl_object x)
{
return equal(t->item_compared, (t->key_c_function)(t, x));
}
static bool
test_equalp(struct cl_test *t, cl_object x)
{
return equalp(t->item_compared, (t->key_c_function)(t, x));
}
static cl_object
key_function(struct cl_test *t, cl_object x)
{
......@@ -74,10 +92,20 @@ setupTEST(struct cl_test *t, cl_object item, cl_object test,
if (test != Cnil) {
if (test_not != Cnil)
FEerror("Both :TEST and :TEST-NOT are specified.", 0);
t->test_function = test;
t->test_c_function = test_compare;
t->test_function = si_coerce_to_function(test);
if (t->test_function == SYM_FUN(@'eq')) {
t->test_c_function = test_eq;
} else if (t->test_function == SYM_FUN(@'eql')) {
t->test_c_function = test_eql;
} else if (t->test_function == SYM_FUN(@'equal')) {
t->test_c_function = test_equal;
} else if (t->test_function == SYM_FUN(@'equalp')) {
t->test_c_function = test_equalp;
} else {
t->test_c_function = test_compare;
}
} else if (test_not != Cnil) {
t->test_function = test_not;
t->test_function = si_coerce_to_function(test_not);
t->test_c_function = test_compare_not;
} else {
t->test_c_function = test_eql;
......
......@@ -343,9 +343,9 @@ cl_boot(int argc, char **argv)
#endif
aux = cl_list(
#ifdef ENABLE_DLOPEN
4,CONS(make_constant_string("fas"), @'si::load-binary'),
6,CONS(make_constant_string("fas"), @'si::load-binary'),
#else
3,
5,
#endif
CONS(make_constant_string("lsp"), @'si::load-source'),
CONS(make_constant_string("lisp"), @'si::load-source'),
......
......@@ -104,7 +104,7 @@ cl_object
si_coerce_to_function(cl_object fun)
{
cl_type t = type_of(fun);
if (!(t == t_cfun || t == t_cclosure
if (!(t == t_cfun || t == t_cclosure || t == t_bytecodes
#ifdef CLOS
|| (t == t_instance && fun->instance.isgf)
#endif
......
......@@ -194,6 +194,7 @@
;;;
(defun compute-applicable-methods (gf args)
(declare (optimize (safety 0) (speed 3)))
(let* ((methods (generic-function-methods gf))
applicable-list
args-specializers)
......
......@@ -80,7 +80,7 @@
(INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t))
((SHORT-FLOAT SINGLE-FLOAT) 'SHORT-FLOAT)
((LONG-FLOAT DOUBLE-FLOAT) 'LONG-FLOAT)
((STREAM) 'STREAM) ; Beppe
((STREAM CONS) type-name) ; Juanjo
(t (cond ((eq type-name 'VALUES)
(unless values-allowed
(error "VALUES type found in a place where it is not allowed."))
......
......@@ -365,64 +365,94 @@
; file list.d
(CAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAR(#0)")
:inline-unsafe ((t) t nil nil "CAR(#0)"))
(CDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDR(#0)")
:inline-unsafe ((t) t nil nil "CDR(#0)"))
(CAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAAR(#0)")
:inline-unsafe ((t) t nil nil "CAAR(#0)"))
(CADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADR(#0)")
:inline-unsafe ((t) t nil nil "CADR(#0)"))
(CDAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDAR(#0)")
:inline-unsafe ((t) t nil nil "CDAR(#0)"))
(CDDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDR(#0)")
:inline-unsafe ((t) t nil nil "CDDR(#0)"))
(CAAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAAAR(#0)")
:inline-unsafe ((t) t nil nil "CAAAR(#0)"))
(CAADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAADR(#0)")
:inline-unsafe ((t) t nil nil "CAADR(#0)"))
(CADAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADAR(#0)")
:inline-unsafe ((t) t nil nil "CADAR(#0)"))
(CADDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADDR(#0)")
:inline-unsafe ((t) t nil nil "CADDR(#0)"))
(CDAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDAAR(#0)")
:inline-unsafe ((t) t nil nil "CDAAR(#0)"))
(CDADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDADR(#0)")
:inline-unsafe ((t) t nil nil "CDADR(#0)"))
(CDDAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDAR(#0)")
:inline-unsafe ((t) t nil nil "CDDAR(#0)"))
(CDDDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDDR(#0)")
:inline-unsafe ((t) t nil nil "CDDDR(#0)"))
(CAAAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAAAAR(#0)")
:inline-unsafe ((t) t nil nil "CAAAAR(#0)"))
(CAAADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAAADR(#0)")
:inline-unsafe ((t) t nil nil "CAAADR(#0)"))
(CAADAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAADAR(#0)")
:inline-unsafe ((t) t nil nil "CAADAR(#0)"))
(CAADDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CAADDR(#0)")
:inline-unsafe ((t) t nil nil "CAADDR(#0)"))
(CADAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADAAR(#0)")
:inline-unsafe ((t) t nil nil "CADAAR(#0)"))
(CADADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADADR(#0)")
:inline-unsafe ((t) t nil nil "CADADR(#0)"))
(CADDAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADDAR(#0)")
:inline-unsafe ((t) t nil nil "CADDAR(#0)"))
(CADDDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CADDDR(#0)")
:inline-unsafe ((t) t nil nil "CADDDR(#0)"))
(CDAAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDAAAR(#0)")
:inline-unsafe ((t) t nil nil "CDAAAR(#0)"))
(CDAADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDAADR(#0)")
:inline-unsafe ((t) t nil nil "CDAADR(#0)"))
(CDADAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDADAR(#0)")
:inline-unsafe ((t) t nil nil "CDADAR(#0)"))
(CDADDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDADDR(#0)")
:inline-unsafe ((t) t nil nil "CDADDR(#0)"))
(CDDAAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDAAR(#0)")
:inline-unsafe ((t) t nil nil "CDDAAR(#0)"))
(CDDADR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDADR(#0)")
:inline-unsafe ((t) t nil nil "CDDADR(#0)"))
(CDDDAR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDDAR(#0)")
:inline-unsafe ((t) t nil nil "CDDDAR(#0)"))
(CDDDDR (T) T NIL NIL
:inline-always ((cons) t nil nil "CDDDDR(#0)")
:inline-unsafe ((t) t nil nil "CDDDDR(#0)"))
(CONS (T T) T NIL NIL
:inline-always ((t t) t nil t "CONS(#0,#1)"))
......
......@@ -35,7 +35,7 @@ The previous step creates a directory with the name <b>build</b>, and
stores a bunch of makefiles in it. <b>Note:</b> If you are building
under Solaris, you should rather use
<pre>
./configure --enable-slow-conf
./configure --enable-slow-config
</pre>
because otherwise ECL will fail to detect the 64-bit capabilities of
the operating system.
......
......@@ -1323,41 +1323,6 @@ extern cl_object ecl_get(cl_object s, cl_object p, cl_object d);
extern bool keywordp(cl_object s);
/* tclBasic.c */
#ifdef TK
extern cl_object TkWidgetType;
extern Tcl_Interp *ECL_interp;
extern int Tcl_GlobalEval(Tcl_Interp *interp, char *s);
extern int Tcl_Eval(Tcl_Interp *interp, char *s);
extern int Tcl_VarEval(Tcl_Interp *interp, ...);
extern char *Tcl_GetVar(Tcl_Interp *interp, char *var, int flags);
extern char *Tcl_GetVar2(Tcl_Interp *interp, char *name1, char *name2, int flags);
extern char *Tcl_SetVar(Tcl_Interp *interp, char *var, char *val, int flags);
extern char *Tcl_SetVar2(Tcl_Interp *interp, char *name1, char *name2, char *val, int flags);
extern int Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName);
extern int tclMethodDispatch(cl_narg narg, cl_object env, ...);
extern void Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc);
extern int Tcl_GetCommandInfo(Tcl_Interp *interp, char *cmdName, Tcl_CmdInfo *infoPtr);
extern Tcl_Interp *Tcl_CreateInterp(void);
extern void Tcl_DeleteInterp(Tcl_Interp *interp);
extern int init_tk(void);
extern int Tcl_Init(Tcl_Interp *interp);
extern void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData);
extern void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData);
extern int Tcl_SetCommandInfo(Tcl_Interp *interp, char *cmdName, Tcl_CmdInfo *infoPtr);
extern Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData);
extern void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace);
extern void Tcl_AddErrorInfo(Tcl_Interp *interp, char *message);
extern int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth);
extern int Tcl_TraceVar(Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData);
extern int Tcl_TraceVar2(Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData);
extern void Tcl_UntraceVar(Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData);
extern void Tcl_UntraceVar2(Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData);
extern void Tcl_ChangeValue(char *var);
#endif
/* tcp.c */
#ifdef TCP
......@@ -1403,16 +1368,6 @@ extern cl_object si_daylight_saving_time_p _ARGS((cl_narg narg, ...));
extern cl_object UTC_time_to_universal_time(cl_fixnum i);
/* tkMain.c */
#ifdef TK
extern Tcl_Interp *ECL_interp;
extern int Tk_initialized;
extern cl_object Tk_root_window;
extern void Tk_main(int synchronize, char *name, char *fileName, char *Xdisplay, char *geometry);
#endif
/* typespec.c */
extern void assert_type_integer(cl_object p);
......
......@@ -48,14 +48,6 @@ extern void ecl_init_env(struct cl_env_struct *);
extern void init_LSP(cl_object);
extern void init_CLOS(cl_object);
/* all_functions.d */
extern const struct {
const char *name;
cl_object (*f)(int, ...);
short type;
} all_functions[];
/* alloc.d/alloc_2.d */
extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size);
......
......@@ -280,11 +280,13 @@ SECOND-FORM."
&aux (temp (gensym)) decl)
(multiple-value-setq (decl body)
(find-declarations body))
`(DO* ((,temp ,form (cdr ,temp)) (,var))
;; Since ENDP did not complain, this is definitely a (CDR ,temp) is safe
`(DO* ((,temp ,form (CDR (THE CONS ,temp))) (,var))
((ENDP ,temp) ,val)
,@decl
(SETQ ,var (CAR ,temp))
,@body))
,@body
))
(defmacro dotimes ((var form &optional (val nil)) &rest body
&aux (temp (gensym)))
......
This diff is collapsed.
......@@ -13,6 +13,7 @@
(in-package "SYSTEM")
(defun check-stores-number (context stores-list n)
(declare (si::c-local))
(unless (= (length stores-list) n)
(error "~d store-variables expected in setf form ~a." n context)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment