* Added $code-annotation and $set-code-annotation! primops

bin/ikarus-collect.c

@@ -886,6 +886,7 @@ add_code_entry(gc_t* gc, ikp entry){
   int code_size = unfix(ref(x, disp_code_code_size));
   ikp reloc_vec = ref(x, disp_code_reloc_vector);
   ikp freevars = ref(x, disp_code_freevars);
+  ikp annotation = ref(x, disp_code_annotation);
   int required_mem = align(disp_code_data + code_size);
   if(required_mem >= pagesize){
     int new_tag = next_gen_tag[gen];
@@ -907,6 +908,7 @@ add_code_entry(gc_t* gc, ikp entry){
     ref(y, disp_code_code_size) = fix(code_size);
     ref(y, disp_code_reloc_vector) = reloc_vec;
     ref(y, disp_code_freevars) = freevars;
+    ref(y, disp_code_annotation) = annotation;
     memcpy(y+disp_code_data, x+disp_code_data, code_size);
     ref(x, 0) = forward_ptr;
     ref(x, wordsize) = y + vector_tag;
@@ -1354,6 +1356,8 @@ relocate_new_code(ikp x, gc_t* gc){
   ikp relocvector = ref(x, disp_code_reloc_vector);
   relocvector = add_object(gc, relocvector, "relocvec");
   ref(x, disp_code_reloc_vector) = relocvector;
+  ref(x, disp_code_annotation) = 
+    add_object(gc, ref(x, disp_code_annotation), "annotation");
   int relocsize = (int)ref(relocvector, off_vector_length);
   ikp p = relocvector + off_vector_data;
   ikp q = p + relocsize;

bin/ikarus-data.h

@@ -10,7 +10,9 @@
 #define disp_code_code_size 4
 #define disp_code_reloc_vector 8
 #define disp_code_freevars 12
+#define disp_code_annotation 16
 #define disp_code_data 24
+#define off_code_annotation (disp_code_annotation - code_pri_tag)
 #define off_code_data (disp_code_data - code_pri_tag)
 #define off_code_reloc_vector (disp_code_reloc_vector - code_pri_tag)
 

bin/ikarus-runtime.c

@@ -747,6 +747,7 @@ ikrt_make_code(ikp codesizeptr, ikp freevars, ikp rvec, ikpcb* pcb){
   ref(mem, disp_code_code_size) = codesizeptr;
   ref(mem, disp_code_freevars) = freevars;
   ref(mem, disp_code_reloc_vector) = rvec;
+  ref(mem, disp_code_annotation) = false_object;
   ik_relocate_code(mem);
   return mem+vector_tag;
 }
@@ -759,6 +760,15 @@ ikrt_set_code_reloc_vector(ikp code, ikp vec, ikpcb* pcb){
   return void_object;
 }
 
+ikp
+ikrt_set_code_annotation(ikp code, ikp annot, ikpcb* pcb){
+  ref(code, off_code_annotation) = annot;
+  pcb->dirty_vector[page_index(code)] = -1;
+  return void_object;
+}
+
+
+
 ikp
 ikrt_bvftime(ikp outbv, ikp fmtbv){
   time_t t;

src/ikarus.code-objects.ss

@@ -3,12 +3,14 @@
   (export
     make-code code-reloc-vector code-freevars
     code-size code-ref code-set! set-code-reloc-vector!
+    set-code-annotation!
     code->thunk)
   (import
     (ikarus system $fx)
     (ikarus system $codes)
     (except (ikarus) make-code code-reloc-vector code-freevars
-            code-size code-ref code-set! set-code-reloc-vector!))
+            code-size code-ref code-set! set-code-reloc-vector!
+            set-code-annotation!))
 
   (define make-code
     (lambda (code-size freevars)
@@ -63,6 +65,13 @@
         (error 'set-code-reloc-vector! "~s is not a vector" v))
       (foreign-call "ikrt_set_code_reloc_vector" x v)))
 
+
+  (define set-code-annotation!
+    (lambda (x v)
+      (unless (code? x) 
+        (error 'set-code-annotation! "~s is not a code" x))
+      (foreign-call "ikrt_set_code_annotation" x v)))
+
   (define code->thunk
     (lambda (x)
       (unless (code? x)

src/ikarus.compiler.ss

@@ -1795,6 +1795,7 @@
   (define disp-code-instrsize      4)
   (define disp-code-relocsize      8)
   (define disp-code-freevars      12)
+  (define disp-code-annotation    16)
   (define disp-code-data          24)
   
   (define port-tag              #x3F)

src/makefile.ss

@@ -775,8 +775,10 @@
     [$code-reloc-vector       $codes]
     [$code-freevars           $codes]
     [$code-size               $codes]
+    [$code-annotation         $codes]
     [$code-ref                $codes]
     [$code-set!               $codes]
+    [$set-code-annotation!    $codes]
 
     [$make-tcbucket           $tcbuckets]
     [$tcbucket-key            $tcbuckets]

src/pass-specify-rep-primops.ss

@@ -1579,6 +1579,9 @@
 (define-primop $code-size unsafe
   [(V x) (prm 'mref (T x) (K (- disp-code-instrsize vector-tag)))])
 
+(define-primop $code-annotation unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-code-annotation vector-tag)))])
+
 (define-primop $code->closure unsafe
   [(V x) 
    (with-tmp ([v (prm 'alloc
@@ -1609,6 +1612,8 @@
              (K (- disp-code-data vector-tag)))
         (prm 'sll (T v) (K (- 8 fixnum-shift))))])
 
+(define-primop $set-code-annotation! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-code-annotation vector-tag))])
 
 /section)