~ chicken-core (chicken-5) 9fcddd51f03fd32a5bdc458efe3573c440f34098
commit 9fcddd51f03fd32a5bdc458efe3573c440f34098
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jul 26 12:01:39 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Jul 26 12:01:39 2010 +0200
special-casing of allocators as C_inline routines
diff --git a/c-platform.scm b/c-platform.scm
index f992f05c..0b48f936 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -844,11 +844,11 @@
(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
-(rewrite 'list 16 #f "C_a_i_list" #t '(3))
+(rewrite 'list 16 #f "C_a_i_list" #t '(3) #t)
(rewrite '##sys#list 16 #f "C_a_i_list" #t '(3))
-(rewrite 'vector 16 #f "C_a_i_vector" #t #t)
+(rewrite 'vector 16 #f "C_a_i_vector" #t #t #t)
(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)
-(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t)
+(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t #t)
(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
(rewrite 'address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
(rewrite 'pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
diff --git a/chicken.h b/chicken.h
index 7e698629..76bd3f67 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1187,7 +1187,7 @@ extern double trunc(double);
# define C_a_i_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_PAIR_TYPE | 2; *a += 3; \
C_set_block_item(tmp, 0, car); C_set_block_item(tmp, 1, cdr); tmp;})
#else
-# define C_a_i_cons(a, n, car, cdr) C_pair(a, car, cdr)
+# define C_a_i_cons(a, n, car, cdr) C_a_pair(a, car, cdr)
#endif /* __GNUC__ */
#define C_a_i_flonum(ptr, i, n) C_flonum(ptr, n)
@@ -2260,6 +2260,345 @@ C_fast_retrieve_symbol_proc(C_word sym)
}
+C_inline C_word C_a_i_vector1(C_word **ptr, int n, C_word x1)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 1;
+ *(p++) = x1;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector2(C_word **ptr, int n, C_word x1, C_word x2)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 2;
+ *(p++) = x1;
+ *(p++) = x2;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 3;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 4;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 5;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 6;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 7;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *(p++) = x7;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_vector8(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7, C_word x8)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | 8;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *(p++) = x7;
+ *(p++) = x8;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_fcall C_a_pair(C_word **ptr, C_word car, C_word cdr)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
+ *(p++) = car;
+ *(p++) = cdr;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_list1(C_word **a, int n, C_word x1)
+{
+ return C_a_pair(a, x1, C_SCHEME_END_OF_LIST);
+}
+
+
+C_inline C_word C_a_i_list2(C_word **a, int n, C_word x1, C_word x2)
+{
+ C_word x = C_a_pair(a, x2, C_SCHEME_END_OF_LIST);
+
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_list3(C_word **a, int n, C_word x1, C_word x2, C_word x3)
+{
+ C_word x = C_pair(a, x3, C_SCHEME_END_OF_LIST);
+
+ x = C_a_pair(a, x2, x);
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_list4(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4)
+{
+ C_word x = C_pair(a, x4, C_SCHEME_END_OF_LIST);
+
+ x = C_a_pair(a, x3, x);
+ x = C_a_pair(a, x2, x);
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_list5(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5)
+{
+ C_word x = C_pair(a, x5, C_SCHEME_END_OF_LIST);
+
+ x = C_a_pair(a, x4, x);
+ x = C_a_pair(a, x3, x);
+ x = C_a_pair(a, x2, x);
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_list6(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6)
+{
+ C_word x = C_pair(a, x6, C_SCHEME_END_OF_LIST);
+
+ x = C_a_pair(a, x5, x);
+ x = C_a_pair(a, x4, x);
+ x = C_a_pair(a, x3, x);
+ x = C_a_pair(a, x2, x);
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_list7(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7)
+{
+ C_word x = C_pair(a, x7, C_SCHEME_END_OF_LIST);
+
+ x = C_a_pair(a, x6, x);
+ x = C_a_pair(a, x5, x);
+ x = C_a_pair(a, x4, x);
+ x = C_a_pair(a, x3, x);
+ x = C_a_pair(a, x2, x);
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_list8(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7, C_word x8)
+{
+ C_word x = C_pair(a, x8, C_SCHEME_END_OF_LIST);
+
+ x = C_a_pair(a, x7, x);
+ x = C_a_pair(a, x6, x);
+ x = C_a_pair(a, x5, x);
+ x = C_a_pair(a, x4, x);
+ x = C_a_pair(a, x3, x);
+ x = C_a_pair(a, x2, x);
+ return C_a_pair(a, x1, x);
+}
+
+
+C_inline C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 1;
+ *(p++) = x1;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record2(C_word **ptr, int n, C_word x1, C_word x2)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 2;
+ *(p++) = x1;
+ *(p++) = x2;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 3;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 4;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 5;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 6;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 7;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *(p++) = x7;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7, C_word x8)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 8;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *(p++) = x7;
+ *(p++) = x8;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
#ifdef C_PRIVATE_REPOSITORY
# if defined(C_MACOSX) && defined(C_GUI)
# include <CoreFoundation/CoreFoundation.h>
diff --git a/optimizer.scm b/optimizer.scm
index 98f5b2ad..0b225971 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1034,15 +1034,18 @@
(else #f) ) ) )
;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
- ((16) ; classargs = (<argc> <aiop> <safe> <words>)
+ ((16) ; classargs = (<argc> <aiop> <safe> <words> [<counted>])
;; - <argc> may be #f, saying that any number of arguments is allowed,
;; - <words> may be a list of one element (the number of words), meaning that
;; the words are to be multiplied with the number of arguments.
;; - <words> may also be #t, meaning that the number of words is the same as the
;; number of arguments plus 1.
- (let ([argc (first classargs)]
- [rargc (length callargs)]
- [w (fourth classargs)] )
+ ;; - if <counted> is given and true and <argc> is between 1-8, append "<count>"
+ ;; to the name of the inline routine.
+ (let ((argc (first classargs))
+ (rargc (length callargs))
+ (w (fourth classargs))
+ (counted (and (pair? (cddddr classargs)) (fifth classargs))))
(and inline-substitutions-enabled
(or (not argc) (= rargc argc))
(intrinsic? name)
@@ -1052,7 +1055,9 @@
(list cont
(make-node
'##core#inline_allocate
- (list (second classargs)
+ (list (if (and counted (positive? rargc) (<= rargc 8))
+ (conc (second classargs) rargc)
+ (second classargs) )
(cond [(eq? #t w) (add1 rargc)]
[(pair? w) (* rargc (car w))]
[else w] ) )
diff --git a/runtime.c b/runtime.c
index a2f6dbe5..50b4fe56 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1690,7 +1690,7 @@ long C_fcall cpu_milliseconds(void)
int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)
{
- C_word p = C_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
+ C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), p);
return ++callback_continuation_level;
@@ -2071,7 +2071,7 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl
C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
*ptr = p;
b2 = stable->table[ key ]; /* previous bucket */
- bucket = C_pair(ptr, sym, b2); /* create new bucket */
+ bucket = C_a_pair(ptr, sym, b2); /* create new bucket */
((C_SCHEME_BLOCK *)bucket)->header =
(((C_SCHEME_BLOCK *)bucket)->header & ~C_HEADER_TYPE_BITS) | C_BUCKET_TYPE;
@@ -2344,6 +2344,7 @@ C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)
}
+/* obsolete: replaced by C_a_pair in chicken.h */
C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)
{
C_word *p = *ptr,
@@ -4364,7 +4365,7 @@ C_word C_a_i_list(C_word **a, int c, ...)
for(last = C_SCHEME_UNDEFINED; c--; last = current) {
x = va_arg(v, C_word);
- current = C_pair(a, x, C_SCHEME_END_OF_LIST);
+ current = C_a_pair(a, x, C_SCHEME_END_OF_LIST);
if(last != C_SCHEME_UNDEFINED)
C_set_block_item(last, 1, current);
@@ -4387,7 +4388,7 @@ C_word C_h_list(int c, ...)
for(last = C_SCHEME_UNDEFINED; c--; last = current) {
x = va_arg(v, C_word);
- current = C_pair(C_heaptop, x, C_SCHEME_END_OF_LIST);
+ current = C_a_pair(C_heaptop, x, C_SCHEME_END_OF_LIST);
if(C_in_stackp(x))
C_mutate(&C_u_i_car(current), x);
@@ -7444,7 +7445,7 @@ void get_argv_2(void *dummy)
*a = C_alloc(cells),
list, str;
- for(list = C_SCHEME_END_OF_LIST; i--; list = C_pair(&a, str, list))
+ for(list = C_SCHEME_END_OF_LIST; i--; list = C_a_pair(&a, str, list))
str = C_string2(&a, C_main_argv[ i ]);
C_kontinue(k, list);
@@ -8789,8 +8790,8 @@ C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
else pl = C_u_i_cdr(C_u_i_cdr(pl));
}
- pl = C_pair(ptr, val, C_block_item(sym, 2));
- pl = C_pair(ptr, prop, pl);
+ pl = C_a_pair(ptr, val, C_block_item(sym, 2));
+ pl = C_a_pair(ptr, prop, pl);
C_mutate(&C_block_item(sym, 2), pl);
return val;
}
diff --git a/tests/runbench.sh b/tests/runbench.sh
index dee74442..6ad82b92 100644
--- a/tests/runbench.sh
+++ b/tests/runbench.sh
@@ -61,6 +61,6 @@ echo -n "fft/unboxed ... "
$compile fft.scm -D unboxed
run
-echo -n "man-or-oby ... "
+echo -n "man-or-boy ... "
$compile man-or-boy.scm
run -:d
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 5729481c..5e6075b7 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -460,3 +460,23 @@
(foo1 bar)
(assert (string=? "hello, XXX" (bar who: "XXX")))
+
+
+;;; import not seen, if explicitly exported and renamed:
+
+#|
+(module foo ((bar baz))
+(import scheme chicken)
+
+(define (baz x)
+ (print x))
+
+(define-syntax bar
+ (syntax-rules ()
+ ((_ x) (baz x))))
+
+)
+
+(import (prefix foo f:))
+(f:bar 1)
+|#
Trap