Example #1
0
char *
scheme_strdup(const char *str)
{
  char *naya;
  long len;

  len = strlen(str) + 1;
  naya = (char *)scheme_malloc_atomic (len * sizeof (char));
  memcpy (naya, str, len);

  return naya;
}
Example #2
0
File: sfs.c Project: awest/racket
SFS_Info *scheme_new_sfs_info(int depth)
{
  SFS_Info *info;
  int *max_used, *max_calls;

  info = MALLOC_ONE_RT(SFS_Info);
  SET_REQUIRED_TAG(info->type = scheme_rt_sfs_info);

  info->depth = depth;
  info->stackpos = depth;
  info->tlpos = depth;

  max_used = (int *)scheme_malloc_atomic(sizeof(int) * depth);
  max_calls = (int *)scheme_malloc_atomic(sizeof(int) * depth);

  memset(max_used, 0, sizeof(int) * depth);
  memset(max_calls, 0, sizeof(int) * depth);

  info->max_used = max_used;
  info->max_calls = max_calls;

  return info;
}
static void *prepare_retry_alloc(void *p, void *p2)
{
  /* Allocate enough to trigger a new page */
  intptr_t avail, algn;

  algn = GC_alloc_alignment();
  avail = algn - (GC_gen0_alloc_page_ptr & (algn - 1));
  
  if (!avail)
    avail = 1;
  else if (avail == algn)
    avail = 1;

  if (avail > sizeof(intptr_t))
    avail -= sizeof(intptr_t);

  /* We assume that atomic memory and tagged go to the same nursery: */
  scheme_malloc_atomic(avail);

  retry_alloc_r1 = p2;

  return p;
}
Example #4
0
/* unused code, may be useful when/if we revive shared symbol and prefab key tables */
Scheme_Struct_Type *scheme_make_prefab_struct_type_in_master(Scheme_Object *base,
					Scheme_Object *parent,
					int num_fields,
					int num_uninit_fields,
					Scheme_Object *uninit_val,
					char *immutable_array)
{
# ifdef MZ_PRECISE_GC
  void *original_gc;
# endif
  Scheme_Object *cname;
  Scheme_Object *cuninit_val;
  char *cimm_array = NULL;
  int local_slots = num_fields + num_uninit_fields;
  Scheme_Struct_Type *stype;

# ifdef MZ_PRECISE_GC
  original_gc = GC_switch_to_master_gc();
  scheme_start_atomic();
# endif

  cname = scheme_places_deep_copy(base);
  cuninit_val = scheme_places_deep_copy(uninit_val);
  if (local_slots) {
    cimm_array   = (char *)scheme_malloc_atomic(local_slots);
    memcpy(cimm_array, immutable_array, local_slots);
  }
  stype = scheme_make_prefab_struct_type_raw(cname, parent, num_fields, num_uninit_fields, cuninit_val, cimm_array);

# ifdef MZ_PRECISE_GC
  scheme_end_atomic_no_swap();
  GC_switch_back_from_master(original_gc);
# endif

  return stype;
}
Example #5
0
void scheme_print_tagged_value(const char *prefix, 
			       void *v, int xtagged, unsigned long diff, int max_w,
			       const char *suffix)
{
  char *type, *sep, diffstr[30];
  long len;
  
  sep = "";
  
  scheme_check_print_is_obj = check_home;

  if (!xtagged) {
    type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w);
    if (!scheme_strncmp(type, "#<thread", 8)) {
      char buffer[256];
      char *run, *sus, *kill, *clean, *deq, *all, *t2;
      int state = ((Scheme_Thread *)v)->running, len2;
	    
      run = (state & MZTHREAD_RUNNING) ? "+run" : "";
      sus = (state & MZTHREAD_SUSPENDED) ? "+suspended" : "";
      kill = (state & MZTHREAD_KILLED) ? "+killed" : "";
      clean = (state & MZTHREAD_NEED_KILL_CLEANUP) ? "+cleanup" : "";
      deq = (((Scheme_Thread *)v)->next || ((Scheme_Thread *)v)->prev) ? "" : "+deq";
      all = !state ? "defunct" : "";

      sprintf(buffer, "[%d=%s%s%s%s%s%s]",
	      state, run, sus, kill, clean, all, deq);

      len2 = strlen(buffer);
      t2 = (char *)scheme_malloc_atomic(len + len2 + 1);
      memcpy(t2, type, len);
      memcpy(t2 + len, buffer, len2 + 1);
      len += len2;
      type = t2;
    } else if (!scheme_strncmp(type, "#<namespace", 11)) {
      char buffer[256];
      char *t2;
      int len2;
	    
      sprintf(buffer, "[%ld:%.100s]",
	      ((Scheme_Env *)v)->phase,
	      (((Scheme_Env *)v)->module
	       ? SCHEME_SYM_VAL(((Scheme_Env *)v)->module->modname)
	       : "(toplevel)"));
	    
      len2 = strlen(buffer);
      t2 = (char *)scheme_malloc_atomic(len + len2 + 1);
      memcpy(t2, type, len);
      memcpy(t2 + len, buffer, len2 + 1);
      len += len2;
      type = t2;
    }  else if (!scheme_strncmp(type, "#<global-variable-code", 22)) {
      Scheme_Bucket *b = (Scheme_Bucket *)v;
      Scheme_Object *bsym = (Scheme_Object *)b->key;
      char *t2;
      int len2;

      len2 = SCHEME_SYM_LEN(bsym);
      t2 = scheme_malloc_atomic(len + len2 + 3);
      memcpy(t2, type, len);
      memcpy(t2 + len + 1, SCHEME_SYM_VAL(bsym), len2);
      t2[len] = '[';
      t2[len + 1 + len2] = ']';
      t2[len + 1 + len2 + 1] = 0;
      len += len2;
      type = t2;
    } else if (!scheme_strncmp(type, "#<hash-table>", 13)
	       || !scheme_strncmp(type, "#<hash-table:", 13)) {
      char buffer[256];
      char *t2;
      int len2;
      int htype, size, count;

      if (SCHEME_HASHTP((Scheme_Object *)v)) {
	htype = 'n';
	size = ((Scheme_Hash_Table *)v)->size;
	count = ((Scheme_Hash_Table *)v)->count;
      } else {
	htype = 'b';
	size = ((Scheme_Bucket_Table *)v)->size;
	count = ((Scheme_Bucket_Table *)v)->count;
      }
      
      sprintf(buffer, "[%c:%d:%d]", htype, count, size);

      len2 = strlen(buffer);
      t2 = scheme_malloc_atomic(len + len2 + 1);
      memcpy(t2, type, len);
      memcpy(t2 + len, buffer, len2 + 1);
      len += len2;
      type = t2;
    } else if (!scheme_strncmp(type, "#<syntax", 8)) {
      char *t2, *t3;
      long len2, len3;

      t2 = scheme_write_to_string_w_max(SCHEME_STX_VAL(v), &len2, 32);
      
      len3 = len + len2 + 2;
      t3 = (char *)scheme_malloc_atomic(len3);
      memcpy(t3, type, len);
      t3[len] = '=';
      memcpy(t3 + len + 1, t2, len2);
      t3[len + len2 + 1] = 0;
      type = t3;
      len = len3;
    }

    sep = "=";
  } else if (scheme_external_dump_type) {
    type = scheme_external_dump_type(v);
    if (*type)
      sep = ":";
  } else
    type = "";
  
  if (diff)
    sprintf(diffstr, "%lx", diff);
  
  object_console_printf(stderr,
			"%s%p%s%s%s%s%s", 
			prefix,
			v, 
			sep,
			type,
			diff ? "+" : "",
			diff ? diffstr : "",
			suffix);

  scheme_check_print_is_obj = NULL;
}