ref: 5edb75af2c767a72484ff9cfd873e900c91c629a
parent: 5681745bc3eff5ebcaa2986137c1df63ae920a7e
author: JeffBezanson <[email protected]>
date: Mon Mar 16 23:29:17 EDT 2009
making nconc, assq, and memq builtins some small optimizations to string.map, string.trim, string.inc, string.dec, aref
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -26,8 +26,60 @@
return n;
}
-value_t fl_exit(value_t *args, u_int32_t nargs)
+static value_t fl_nconc(value_t *args, u_int32_t nargs)
{+ if (nargs == 0)
+ return NIL;
+ value_t first=NIL;
+ value_t *pcdr = &first;
+ cons_t *c;
+ int a;
+ for(a=0; a < (int)nargs-1; a++) {+ if (iscons(args[a])) {+ *pcdr = args[a];
+ c = (cons_t*)ptr(args[a]);
+ while (iscons(c->cdr))
+ c = (cons_t*)ptr(c->cdr);
+ pcdr = &c->cdr;
+ }
+ else if (args[a] != NIL) {+ type_error("nconc", "cons", args[a]);+ }
+ }
+ *pcdr = args[a];
+ return first;
+}
+
+static value_t fl_assq(value_t *args, u_int32_t nargs)
+{+ argcount("assq", nargs, 2);+ value_t item = args[0];
+ value_t v = args[1];
+ value_t bind;
+
+ while (iscons(v)) {+ bind = car_(v);
+ if (iscons(bind) && car_(bind) == item)
+ return bind;
+ v = cdr_(v);
+ }
+ return FL_F;
+}
+
+static value_t fl_memq(value_t *args, u_int32_t nargs)
+{+ argcount("memq", nargs, 2);+ while (iscons(args[1])) {+ cons_t *c = (cons_t*)ptr(args[1]);
+ if (c->car == args[0])
+ return args[1];
+ args[1] = c->cdr;
+ }
+ return FL_F;
+}
+
+static value_t fl_exit(value_t *args, u_int32_t nargs)
+{if (nargs > 0)
exit(tofixnum(args[0], "exit"));
exit(0);
@@ -34,7 +86,7 @@
return NIL;
}
-value_t fl_intern(value_t *args, u_int32_t nargs)
+static value_t fl_intern(value_t *args, u_int32_t nargs)
{ argcount("intern", nargs, 1);if (!isstring(args[0]))
@@ -42,7 +94,7 @@
return symbol(cvalue_data(args[0]));
}
-value_t fl_setconstant(value_t *args, u_int32_t nargs)
+static value_t fl_setconstant(value_t *args, u_int32_t nargs)
{ argcount("set-constant!", nargs, 2);symbol_t *sym = tosymbol(args[0], "set-constant!");
@@ -55,7 +107,7 @@
extern value_t LAMBDA;
-value_t fl_setsyntax(value_t *args, u_int32_t nargs)
+static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
{ argcount("set-syntax!", nargs, 2);symbol_t *sym = tosymbol(args[0], "set-syntax!");
@@ -73,7 +125,7 @@
return args[1];
}
-value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
+static value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
{ argcount("symbol-syntax", nargs, 1);symbol_t *sym = tosymbol(args[0], "symbol-syntax");
@@ -111,7 +163,7 @@
extern symbol_t *symtab;
-value_t fl_syntax_env(value_t *args, u_int32_t nargs)
+static value_t fl_syntax_env(value_t *args, u_int32_t nargs)
{(void)args;
argcount("syntax-environment", nargs, 0);@@ -130,7 +182,7 @@
extern value_t QUOTE;
-value_t fl_constantp(value_t *args, u_int32_t nargs)
+static value_t fl_constantp(value_t *args, u_int32_t nargs)
{ argcount("constant?", nargs, 1);if (issymbol(args[0]))
@@ -143,7 +195,7 @@
return FL_T;
}
-value_t fl_integerp(value_t *args, u_int32_t nargs)
+static value_t fl_integerp(value_t *args, u_int32_t nargs)
{ argcount("integer?", nargs, 1);value_t v = args[0];
@@ -172,7 +224,7 @@
return FL_F;
}
-value_t fl_fixnum(value_t *args, u_int32_t nargs)
+static value_t fl_fixnum(value_t *args, u_int32_t nargs)
{ argcount("fixnum", nargs, 1); if (isfixnum(args[0])) {@@ -194,7 +246,7 @@
lerror(ArgError, "fixnum: cannot convert argument");
}
-value_t fl_truncate(value_t *args, u_int32_t nargs)
+static value_t fl_truncate(value_t *args, u_int32_t nargs)
{ argcount("truncate", nargs, 1);if (isfixnum(args[0]))
@@ -217,7 +269,7 @@
type_error("truncate", "number", args[0]);}
-value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
+static value_t fl_vector_alloc(value_t *args, u_int32_t nargs)
{fixnum_t i;
value_t f, v;
@@ -239,7 +291,7 @@
return v;
}
-value_t fl_time_now(value_t *args, u_int32_t nargs)
+static value_t fl_time_now(value_t *args, u_int32_t nargs)
{ argcount("time.now", nargs, 0);(void)args;
@@ -258,7 +310,7 @@
type_error(fname, "number", a);
}
-value_t fl_time_string(value_t *args, uint32_t nargs)
+static value_t fl_time_string(value_t *args, uint32_t nargs)
{ argcount("time.string", nargs, 1);double t = todouble(args[0], "time.string");
@@ -267,7 +319,7 @@
return string_from_cstr(buf);
}
-value_t fl_path_cwd(value_t *args, uint32_t nargs)
+static value_t fl_path_cwd(value_t *args, uint32_t nargs)
{if (nargs > 1)
argcount("path.cwd", nargs, 1);@@ -282,7 +334,7 @@
return FL_T;
}
-value_t fl_os_getenv(value_t *args, uint32_t nargs)
+static value_t fl_os_getenv(value_t *args, uint32_t nargs)
{ argcount("os.getenv", nargs, 1);char *name = tostring(args[0], "os.getenv");
@@ -293,7 +345,7 @@
return cvalue_static_cstring(val);
}
-value_t fl_os_setenv(value_t *args, uint32_t nargs)
+static value_t fl_os_setenv(value_t *args, uint32_t nargs)
{ argcount("os.setenv", nargs, 2);char *name = tostring(args[0], "os.setenv");
@@ -310,7 +362,7 @@
return FL_T;
}
-value_t fl_rand(value_t *args, u_int32_t nargs)
+static value_t fl_rand(value_t *args, u_int32_t nargs)
{(void)args; (void)nargs;
fixnum_t r;
@@ -321,7 +373,7 @@
#endif
return fixnum(r);
}
-value_t fl_rand32(value_t *args, u_int32_t nargs)
+static value_t fl_rand32(value_t *args, u_int32_t nargs)
{(void)args; (void)nargs;
ulong r = random();
@@ -331,18 +383,18 @@
return mk_uint32(r);
#endif
}
-value_t fl_rand64(value_t *args, u_int32_t nargs)
+static value_t fl_rand64(value_t *args, u_int32_t nargs)
{(void)args; (void)nargs;
uint64_t r = (((uint64_t)random())<<32) | random();
return mk_uint64(r);
}
-value_t fl_randd(value_t *args, u_int32_t nargs)
+static value_t fl_randd(value_t *args, u_int32_t nargs)
{(void)args; (void)nargs;
return mk_double(rand_double());
}
-value_t fl_randf(value_t *args, u_int32_t nargs)
+static value_t fl_randf(value_t *args, u_int32_t nargs)
{(void)args; (void)nargs;
return mk_float(rand_float());
@@ -365,6 +417,9 @@
{ "fixnum", fl_fixnum }, { "truncate", fl_truncate }, { "integer?", fl_integerp },+ { "nconc", fl_nconc },+ { "assq", fl_assq },+ { "memq", fl_memq }, { "vector.alloc", fl_vector_alloc },--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -275,7 +275,7 @@
num_init(float, double, T_FLOAT)
num_init(double, double, T_DOUBLE)
-#define num_ctor(typenam, ctype, tag) \
+#define num_ctor_init(typenam, ctype, tag) \
value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
{ \ if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \@@ -284,7 +284,9 @@
args[0], cp_data((cprim_t*)ptr(cp)))) \
type_error(#typenam, "number", args[0]); \
return cp; \
-} \
+}
+
+#define num_ctor_ctor(typenam, ctype, tag) \
value_t mk_##typenam(ctype##_t n) \
{ \value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \
@@ -292,6 +294,10 @@
return cp; \
}
+#define num_ctor(typenam, ctype, tag) \
+ num_ctor_init(typenam, ctype, tag) \
+ num_ctor_ctor(typenam, ctype, tag)
+
num_ctor(int8, int8, T_INT8)
num_ctor(uint8, uint8, T_UINT8)
num_ctor(int16, int16, T_INT16)
@@ -823,8 +829,20 @@
{char *data; ulong_t index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
- value_t el = cvalue(eltype, eltype->size);
+ value_t el;
+ numerictype_t nt = eltype->numtype;
+ if (nt >= T_INT32)
+ el = cvalue(eltype, eltype->size);
check_addr_args("aref", args[0], args[1], &data, &index);+ if (nt < T_INT32) {+ if (nt == T_INT8)
+ return fixnum((int8_t)data[index]);
+ else if (nt == T_UINT8)
+ return fixnum((uint8_t)data[index]);
+ else if (nt == T_INT16)
+ return fixnum(((int16_t*)data)[index]);
+ return fixnum(((uint16_t*)data)[index]);
+ }
char *dest = cptr(el);
size_t sz = eltype->size;
if (sz == 1)
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -71,7 +71,7 @@
"compare",
// sequences
- "vector", "aref", "aset!", "length", "assq", "for",
+ "vector", "aref", "aset!", "length", "for",
"", "", "" };
#define N_STACK 98304
@@ -608,20 +608,6 @@
// eval -----------------------------------------------------------------------
-// return a cons element of v whose car is item
-static value_t assq(value_t item, value_t v)
-{- value_t bind;
-
- while (iscons(v)) {- bind = car_(v);
- if (iscons(bind) && car_(bind) == item)
- return bind;
- v = cdr_(v);
- }
- return FL_F;
-}
-
/*
take the final cdr as an argument so the list builtin can give
the same result as (lambda x x).
@@ -1298,10 +1284,6 @@
if (__unlikely(nargs < 1))
lerror(ArgError, "prog1: too few arguments");
v = Stack[saveSP+1];
- break;
- case F_ASSQ:
- argcount("assq", nargs, 2);- v = assq(Stack[SP-2], Stack[SP-1]);
break;
case F_FOR:
argcount("for", nargs, 3);--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -112,7 +112,7 @@
F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR, F_ASH,
F_COMPARE,
- F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_FOR,
+ F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_FOR,
F_TRUE, F_FALSE, F_NIL,
N_BUILTINS,
};
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -264,7 +264,7 @@
while (cnt--) {if (i >= len)
bounds_error("string.inc", args[0], args[1]);- u8_inc(s, &i);
+ (void)(isutf(s[++i]) || isutf(s[++i]) || isutf(s[++i]) || ++i);
}
return size_wrap(i);
}
@@ -285,7 +285,7 @@
while (cnt--) {if (i == 0)
bounds_error("string.dec", args[0], args[1]);- u8_dec(s, &i);
+ (void)(isutf(s[--i]) || isutf(s[--i]) || isutf(s[--i]) || --i);
}
return size_wrap(i);
}
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -60,14 +60,6 @@
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds))))
#f))
-(define (nconc . lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- ((null? (car lsts)) (apply nconc (cdr lsts)))
- (#t (prog1 (car lsts)
- (set-cdr! (last (car lsts))
- (apply nconc (cdr lsts)))))))
-
(define (append . lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
@@ -81,10 +73,6 @@
(cond ((atom? lst) #f)
((equal? (car lst) item) lst)
(#t (member item (cdr lst)))))
-(define (memq item lst)
- (cond ((atom? lst) #f)
- ((eq? (car lst) item) lst)
- (#t (memq item (cdr lst)))))
(define (memv item lst)
(cond ((atom? lst) #f)
((eqv? (car lst) item) lst)
@@ -121,9 +109,6 @@
(define (cadr x) (car (cdr x)))
-;(set! *special-forms* '(quote cond if and or while lambda trycatch
-; set! begin))
-
(define (macroexpand e)
((label mexpand
(lambda (e env f)
@@ -574,16 +559,16 @@
(define (string.trim s at-start at-end)
(define (trim-start s chars i L)
- (if (and (< i L)
- (string.find chars (string.char s i)))
- (trim-start s chars (string.inc s i) L)
+ (if (and (#.< i L)
+ (#.string.find chars (#.string.char s i)))
+ (trim-start s chars (#.string.inc s i) L)
i))
(define (trim-end s chars i)
(if (and (> i 0)
- (string.find chars (string.char s (string.dec s i))))
- (trim-end s chars (string.dec s i))
+ (#.string.find chars (#.string.char s (#.string.dec s i))))
+ (trim-end s chars (#.string.dec s i))
i))
- (let ((L (length s)))
+ (let ((L (#.length s)))
(string.sub s
(trim-start s at-start 0 L)
(trim-end s at-end L))))
@@ -590,11 +575,11 @@
(define (string.map f s)
(let ((b (buffer))
- (n (length s)))
+ (n (#.length s)))
(let ((i 0))
- (while (< i n)
- (begin (io.putc b (f (string.char s i)))
- (set! i (string.inc s i)))))
+ (while (#.< i n)
+ (begin (#.io.putc b (f (#.string.char s i)))
+ (set! i (#.string.inc s i)))))
(io.tostring! b)))
(define (print-to-string v)
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -137,6 +137,8 @@
instead, unless the value is part of an aggregate (e.g. struct).
. this avoids allocating a new type for every size.
. and/or add function array.alloc
+x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
+ . this made no difference in a string.map microbenchmark
bugs:
* with the fully recursive (simpler) relocate(), the size of cons chains
@@ -956,8 +958,6 @@
* make raising a memory error non-consing
- eliminate string copy in lerror() when possible
* fix printing lists of short strings
-
-- preallocate all byte,int8,uint8 values, and some wchars
- remaining c types
- remaining cvalues functions