Implement primitive to read linkage-section info.

diff --git a/v7/src/microcode/cmpgc.h b/v7/src/microcode/cmpgc.h
index bd38beca4995a4cfeeaff0c68a3205d543db10e3..cfc504acddc5ac3f11879bf01344fc2195477344 100644 (file)
--- a/v7/src/microcode/cmpgc.h
+++ b/v7/src/microcode/cmpgc.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: cmpgc.h,v 1.38 2008/01/30 20:02:11 cph Exp $
+$Id: cmpgc.h,v 1.39 2009/02/22 09:00:47 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -52,6 +52,9 @@ USA.
 #ifndef START_OPERATOR_RELOCATION
 #  define START_OPERATOR_RELOCATION(scan, reference) do {} while (false)
 #endif
+#ifndef OPERATOR_RELOCATION_OFFSET
+#  define OPERATOR_RELOCATION_OFFSET 0
+#endif
 
 #ifdef CC_SUPPORT_P
 #define CC_TRANSPORT_END() do                                          \

diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c
index 3e06df22e643a20d14d21ac149cfc972c18cb594..49aae713d7410331d6b14a0bc20b6cb174831d26 100644 (file)
--- a/v7/src/microcode/cmpint.c
+++ b/v7/src/microcode/cmpint.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: cmpint.c,v 1.119 2008/02/14 08:20:22 riastradh Exp $
+$Id: cmpint.c,v 1.120 2009/02/22 09:00:47 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -153,12 +153,18 @@ static bool link_section_handler
   (linkage_section_type_t, cache_handler_t **, bool *);
 static void back_out_of_link_section (link_cc_state_t *);
 static void restore_link_cc_state (link_cc_state_t *);
+static void count_linkage_sections
+  (SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long *, unsigned long *);
+static SCHEME_OBJECT read_linkage_sections
+  (SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long, unsigned long);
+static bool section_execute_p (SCHEME_OBJECT);
 static void setup_compiled_invocation_from_primitive
   (SCHEME_OBJECT, unsigned long);
 static long setup_compiled_invocation (SCHEME_OBJECT, unsigned long);
 static long setup_lexpr_invocation
   (SCHEME_OBJECT, unsigned long, unsigned long);
 static bool open_gap (unsigned long, unsigned long);
+static bool unlinked_section_start_p (SCHEME_OBJECT *, SCHEME_OBJECT *);
 static bool cc_block_address_closure_p (SCHEME_OBJECT *);
 static void write_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT *);
 static long make_fake_uuo_link (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
@@ -1011,6 +1017,91 @@ restore_link_cc_state (link_cc_state_t * s)
   (s->type) = (linkage_section_type (* (s->scan0)));
 }
 \f
+SCHEME_OBJECT
+cc_block_linkage_info (SCHEME_OBJECT block)
+{
+  SCHEME_OBJECT * const_addr
+    = (VECTOR_LOC (block, (1 + (VECTOR_LENGTH (MAKE_POINTER_OBJECT (TC_VECTOR, (VECTOR_LOC (block, 0))))))));
+  SCHEME_OBJECT * block_end = (CC_BLOCK_END (block));
+  unsigned long n_sections;
+  unsigned long n_words;
+
+  count_linkage_sections (const_addr, block_end, (&n_sections), (&n_words));
+  Primitive_GC_If_Needed (n_words);
+  return (read_linkage_sections (const_addr, block_end, n_sections, n_words));
+}
+
+static void
+count_linkage_sections (SCHEME_OBJECT * const_addr,
+                       SCHEME_OBJECT * block_end,
+                       unsigned long * n_sections,
+                       unsigned long * n_words)
+{
+  SCHEME_OBJECT * scan = const_addr;
+  (*n_sections) = 0;
+  (*n_words) = 1;
+  while (unlinked_section_start_p (scan, block_end))
+    {
+      SCHEME_OBJECT h = (*scan++);
+      unsigned long count = (linkage_section_count (h));
+      (*n_sections) += 1;
+      /* One word for sections vector, one word for vector header,
+        one word for type, rest for names.  */
+      (*n_words) += (3 + count);
+      scan +=
+       ((section_execute_p (h))
+        ? (OPERATOR_RELOCATION_OFFSET + (count * UUO_LINK_SIZE))
+        : count);
+    }
+}
+
+static SCHEME_OBJECT
+read_linkage_sections (SCHEME_OBJECT * const_addr,
+                      SCHEME_OBJECT * block_end,
+                      unsigned long n_sections,
+                      unsigned long n_words)
+{
+  SCHEME_OBJECT * scan = const_addr;
+  SCHEME_OBJECT sections = (make_vector (n_sections, SHARP_F, false));
+  SCHEME_OBJECT * sp = (VECTOR_LOC (sections, 0));
+  SCHEME_OBJECT * spe = (VECTOR_LOC (sections, (VECTOR_LENGTH (sections))));
+  while (sp < spe)
+    {
+      SCHEME_OBJECT h = (*scan++);
+      SCHEME_OBJECT section
+       = (make_vector ((1 + (linkage_section_count (h))), SHARP_F, false));
+      SCHEME_OBJECT * p = (VECTOR_LOC (section, 0));
+      SCHEME_OBJECT * pe = (VECTOR_LOC (section, (VECTOR_LENGTH (section))));
+
+      (*p++) = (ULONG_TO_FIXNUM ((unsigned long) (linkage_section_type (h))));
+      if (section_execute_p (h))
+       {
+         scan += OPERATOR_RELOCATION_OFFSET;
+         while (p < pe)
+           {
+             (*p++) = (read_uuo_symbol (scan));
+             scan += UUO_LINK_SIZE;
+           }
+       }
+      else
+       while (p < pe)
+         (*p++) = (*scan++);
+
+      (*sp++) = section;
+    }
+
+  return (sections);
+}
+
+static bool
+section_execute_p (SCHEME_OBJECT h)
+{
+  linkage_section_type_t type = (linkage_section_type (h));
+  return
+    ((type == LINKAGE_SECTION_TYPE_OPERATOR)
+     || (type == LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR));
+}
+\f
 /* Interrupt/GC from Scheme
 
    These procedures are called from compiled code at the start
@@ -1648,6 +1739,16 @@ plausible_cc_block_p (SCHEME_OBJECT * block)
   }
 }
 
+static bool
+unlinked_section_start_p (SCHEME_OBJECT * mp, SCHEME_OBJECT * end)
+{
+  SCHEME_OBJECT marker = (*mp);
+  return
+    ((FIXNUM_P (marker))
+     && (((OBJECT_DATUM (marker)) >> 16) < N_LINKAGE_SECTION_TYPES)
+     && ((mp + 1 + ((OBJECT_DATUM (marker)) & 0xFFFFUL)) < end));
+}
+
 linkage_section_type_t
 linkage_section_type (SCHEME_OBJECT marker)
 {

diff --git a/v7/src/microcode/cmpint.h b/v7/src/microcode/cmpint.h
index b7c659f399020c4cdc59685dcbd47bd7b2c2a5c0..eb22da9fac28601103fb71bf311ba2bd9f6b5e4f 100644 (file)
--- a/v7/src/microcode/cmpint.h
+++ b/v7/src/microcode/cmpint.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: cmpint.h,v 10.20 2008/02/14 06:47:33 cph Exp $
+$Id: cmpint.h,v 10.21 2009/02/22 09:00:47 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -381,6 +381,7 @@ extern SCHEME_OBJECT reflect_to_interface;
 
 extern SCHEME_OBJECT cc_block_debugging_info (SCHEME_OBJECT);
 extern SCHEME_OBJECT cc_block_environment (SCHEME_OBJECT);
+extern SCHEME_OBJECT cc_block_linkage_info (SCHEME_OBJECT);
 
 extern long enter_compiled_expression (void);
 extern void guarantee_cc_return (unsigned long);

diff --git a/v7/src/microcode/cmpintmd/i386.h b/v7/src/microcode/cmpintmd/i386.h
index e744ae99adc3e1dc170dcef89d441e4448eb4561..df91ded3d50ac3dee3154425b0544ce2e59c197e 100644 (file)
--- a/v7/src/microcode/cmpintmd/i386.h
+++ b/v7/src/microcode/cmpintmd/i386.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: i386.h,v 1.42 2008/01/30 20:02:24 cph Exp $
+$Id: i386.h,v 1.43 2009/02/22 09:00:47 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -233,6 +233,8 @@ typedef struct
   (scan) += 1;                                                         \
 } while (false)
 
+#define OPERATOR_RELOCATION_OFFSET 1
+
 #define READ_COMPILED_CLOSURE_TARGET(a, r)                             \
   read_compiled_closure_target ((a), (&r))
 

diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c
index 103bd9f7c9c59a2783eb6deb94ff2af8ed73dcb4..5147a7e283ccce00838f11635b39852c62eae07a 100644 (file)
--- a/v7/src/microcode/sysprim.c
+++ b/v7/src/microcode/sysprim.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: sysprim.c,v 9.58 2008/09/28 21:53:10 cph Exp $
+$Id: sysprim.c,v 9.59 2009/02/22 09:00:47 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -196,9 +196,16 @@ DEFINE_PRIMITIVE ("WRITE-FLOAT-TO-MEMORY", Prim_write_float_to_memory, 2, 2,
 Write FLOAT to memory at ADDRESS.")
 {
   PRIMITIVE_HEADER (2);
-   (* ((double *) (arg_ulong_integer (2)))) = (arg_flonum (1));
+  (* ((double *) (arg_ulong_integer (2)))) = (arg_flonum (1));
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
+
+DEFINE_PRIMITIVE ("CC-BLOCK-LINKAGE-INFO", Prim_cc_block_linkage_info, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, CC_BLOCK_P);
+  PRIMITIVE_RETURN (cc_block_linkage_info (ARG_REF (1)));
+}
 \f
 #ifndef __GNUC__
 #  pragma STDC FENV_ACCESS on