~ chicken-core (chicken-5) 40e476a52d5a9d5904a729adf477251710579677
commit 40e476a52d5a9d5904a729adf477251710579677
Author: Kooda <kooda@upyum.com>
AuthorDate: Wed May 18 10:48:58 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun May 22 13:11:11 2016 +1200
Make locative-ref inlineable (ticket #1260)
- Deprecate C_locative_ref
- Add C_a_i_locative_ref
- Add a compiler rewrite for locative-ref
- Add a specialization for locative-ref on locatives
Signed-off-by: Peter Bex <peter@more-magic.net>
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index a1e54e6f..3d0b0b54 100644
--- a/NEWS
+++ b/NEWS
@@ -37,6 +37,12 @@
- Removed support for (define-syntax (foo e r c) ...), which was
undocumented and not officially supported anyway.
+4.11.1
+
+- Runtime system:
+ - C_locative_ref has been deprecated in favor of C_a_i_locative_ref,
+ which is faster because it is inlined (#1260, thanks to Kooda).
+
4.11.0
- Security fixes
diff --git a/c-platform.scm b/c-platform.scm
index 8cb1fa59..9d596dc3 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -430,7 +430,6 @@
(rewrite 'call-with-values 13 2 "C_call_with_values" #t)
(rewrite '##sys#call-with-values 13 2 "C_u_call_with_values" #f)
(rewrite '##sys#call-with-values 13 2 "C_call_with_values" #t)
-(rewrite 'chicken.locative#locative-ref 13 1 "C_locative_ref" #t)
(rewrite 'chicken.continuation#continuation-graft 13 2 "C_continuation_graft" #t)
(rewrite 'caar 2 1 "C_u_i_caar" #f)
@@ -749,6 +748,7 @@
(rewrite 'chicken.lolevel#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
(rewrite 'chicken.lolevel#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
(rewrite 'chicken.lolevel#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)
+(rewrite 'chicken.locative#locative-ref 16 1 "C_a_i_locative_ref" #t 6)
(rewrite 'chicken.lolevel#pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)
(rewrite 'chicken.lolevel#pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)
diff --git a/chicken.h b/chicken.h
index 0bfd5fd0..6d29f70f 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1967,7 +1967,7 @@ C_fctexport C_cpsproc(C_register_finalizer) C_noret;
C_fctexport C_cpsproc(C_set_dlopen_flags) C_noret;
C_fctexport C_cpsproc(C_dload) C_noret;
C_fctexport C_cpsproc(C_become) C_noret;
-C_fctexport C_cpsproc(C_locative_ref) C_noret;
+C_fctexport C_cpsproc(C_locative_ref) C_noret; /* DEPRECATED */
C_fctexport C_cpsproc(C_call_with_cthulhu) C_noret;
C_fctexport C_cpsproc(C_copy_closure) C_noret;
C_fctexport C_cpsproc(C_dump_heap_state) C_noret;
@@ -2086,6 +2086,7 @@ C_fctexport C_word C_fcall C_i_char_greaterp(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_char_lessp(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_char_greater_or_equal_p(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_char_less_or_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc) C_regparm;
C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
C_fctexport C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak) C_regparm;
diff --git a/lolevel.scm b/lolevel.scm
index e10b446c..d226166b 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -589,7 +589,8 @@ EOF
(define locative-ref
(getter-with-setter
- (##core#primitive "C_locative_ref")
+ (lambda (loc)
+ (##core#inline_allocate ("C_a_i_locative_ref" 6) loc))
locative-set!
"(locative-ref loc)"))
diff --git a/runtime.c b/runtime.c
index 58706e73..dee13bc3 100644
--- a/runtime.c
+++ b/runtime.c
@@ -972,7 +972,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_peek_uint64);
C_pte(C_context_switch);
C_pte(C_register_finalizer);
- C_pte(C_locative_ref);
+ C_pte(C_locative_ref); /* OBSOLETE */
C_pte(C_copy_closure);
C_pte(C_dump_heap_state);
C_pte(C_filter_heap_objects);
@@ -12376,7 +12376,7 @@ C_regparm C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_w
return (C_word)loc;
}
-
+/* DEPRECATED */
void C_ccall C_locative_ref(C_word c, C_word *av)
{
C_word
@@ -12419,6 +12419,33 @@ void C_ccall C_locative_ref(C_word c, C_word *av)
}
}
+C_regparm C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc)
+{
+ C_word *ptr;
+
+ if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-ref", loc);
+
+ ptr = (C_word *)C_block_item(loc, 0);
+
+ if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);
+
+ switch(C_unfix(C_block_item(loc, 2))) {
+ case C_SLOT_LOCATIVE: return *ptr;
+ case C_CHAR_LOCATIVE: return C_make_character(*((char *)ptr));
+ case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));
+ case C_S8_LOCATIVE: return C_fix(*((char *)ptr));
+ case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));
+ case C_S16_LOCATIVE: return C_fix(*((short *)ptr));
+ case C_U32_LOCATIVE: return C_unsigned_int_to_num(a, *((C_u32 *)ptr));
+ case C_S32_LOCATIVE: return C_int_to_num(a, *((C_s32 *)ptr));
+ case C_U64_LOCATIVE: return C_uint64_to_num(a, *((C_u64 *)ptr));
+ case C_S64_LOCATIVE: return C_int64_to_num(a, *((C_s64 *)ptr));
+ case C_F32_LOCATIVE: return C_flonum(a, *((float *)ptr));
+ case C_F64_LOCATIVE: return C_flonum(a, *((double *)ptr));
+ default: panic(C_text("bad locative type"));
+ }
+}
C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)
{
diff --git a/types.db b/types.db
index 35df2302..227fd72e 100644
--- a/types.db
+++ b/types.db
@@ -1827,7 +1827,8 @@
;; locative
(chicken.locative#locative->object (#(procedure #:clean #:enforce) chicken.locative#locative->object (locative) *))
-(chicken.locative#locative-ref (#(procedure #:clean #:enforce) chicken.locative#locative-ref (locative) *))
+(chicken.locative#locative-ref (#(procedure #:clean #:enforce) chicken.locative#locative-ref (locative) *)
+ ((locative) (##core#inline_allocate ("C_a_i_locative_ref" 6) #(1))))
(chicken.locative#locative-set! (#(procedure #:enforce) chicken.locative#locative-set! (locative *) *))
(chicken.locative#locative? (#(procedure #:pure #:predicate locative) chicken.locative#locative? (*) boolean))
(chicken.locative#make-locative (#(procedure #:clean #:enforce) chicken.locative#make-locative (* #!optional fixnum) locative))
Trap