Exemplo n.º 1
0
CAMLprim value camltk_setvar(value var, value contents)
{
  char *s;
  char *stable_var = NULL;
  char *utf_contents;
  CheckInit();

  /* SetVar makes a copy of the contents. */
  /* In case we have write traces in OCaml, it's better to make sure that
     var doesn't move... */
  stable_var = string_to_c(var);
  utf_contents = caml_string_to_tcl(contents);
  s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents,
                         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  stat_free(stable_var);
  if( s == utf_contents ){
    tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!");
  }
  stat_free(utf_contents);

  if (s == NULL)
    tk_error(Tcl_GetStringResult(cltclinterp));
  else 
    return(Val_unit);
}
Exemplo n.º 2
0
Arquivo: win32.c Projeto: OpenXT/ocaml
static DWORD WINAPI caml_thread_start(void * arg)
{
  caml_thread_t th = (caml_thread_t) arg;
  value clos;

  /* Associate the thread descriptor with the thread */
  TlsSetValue(thread_descriptor_key, (void *) th);
  TlsSetValue(last_channel_locked_key, NULL);
  /* Acquire the global mutex and set up the stack variables */
  leave_blocking_section();
  /* Callback the closure */
  clos = Start_closure(th->descr);
  modify(&(Start_closure(th->descr)), Val_unit);
  callback_exn(clos, Val_unit);
  /* Remove th from the doubly-linked list of threads */
  th->next->prev = th->prev;
  th->prev->next = th->next;
  /* Release the main mutex (forever) */
  ReleaseMutex(caml_mutex);
#ifndef NATIVE_CODE
  /* Free the memory resources */
  stat_free(th->stack_low);
  if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
#endif
  /* Free the thread descriptor */
  stat_free(th);
  /* The thread now stops running */
  return 0;
}
Exemplo n.º 3
0
value string_mlval(value val)
{
  value s;
  byteoffset_t res;

  extern_size = INITIAL_EXTERN_SIZE;
  extern_block =
    (byteoffset_t *) stat_alloc(extern_size * sizeof(unsigned long));
  extern_pos = 0;
  extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
  alloc_extern_table();
  extern_table_used = 0;
  res = emit_all(val);
  stat_free((char *) extern_table);

  /* We can allocate a string in the heap since the argument value is
     not used from now on. */
  if (extern_pos == 0)
    {
      s = alloc_string(8);
      ((size_t *)s)[0] = (size_t)extern_pos;
      ((size_t *)s)[1] = (size_t)res;
    }
  else
    {
      s = alloc_string(4 + extern_pos * sizeof(unsigned long));
      ((size_t *)s)[0] = (size_t)extern_pos;
      memmove(&Byte(s, 4), (char *)extern_block, extern_pos * sizeof(unsigned long));
    }
  stat_free((char *) extern_block);
  return s;
}
Exemplo n.º 4
0
/* Parsing results */
CAMLprim value camltk_splitlist (value v)
{
    int argc;
    char **argv;
    int result;
    char *utf;

    CheckInit();

    utf = caml_string_to_tcl(v);
    /* argv is allocated by Tcl, to be freed by us */
    result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
    switch(result) {
    case TCL_OK:
    {   value res = copy_string_list(argc,argv);
        Tcl_Free((char *)argv);    /* only one large block was allocated */
        /* argv points into utf: utf must be freed after argv are freed */
        stat_free( utf );
        return res;
    }
    case TCL_ERROR:
    default:
        stat_free( utf );
        tk_error(Tcl_GetStringResult(cltclinterp));
    }
}
Exemplo n.º 5
0
Arquivo: muddy.c Projeto: Armael/HOL
/* ML type: fddvar vector -> fddvar vector -> pairSet */
EXTERNML value mlfdd_setpairs(value oldvar, value newvar) /* ML */
{
  int size, i, *o, *n;
  bddPair *pairs;
  value result;

  size = Wosize_val(oldvar);

  /* we use stat_alloc which guarantee that we get the memory (or it
     will raise an exception). */
  o    = (int *) stat_alloc(sizeof(int) * size);
  n    = (int *) stat_alloc(sizeof(int) * size);

  for (i=0; i<size; i++) {
     o[i] = Int_val(Field(oldvar, i));
     n[i] = Int_val(Field(newvar, i));
  }

  pairs = bdd_newpair();
  fdd_setpairs(pairs, o, n, size);

  /* memory allocated with stat_alloc, should be freed with
     stat_free.*/
  stat_free((char *) o);
  stat_free((char *) n);

  result = mlbdd_alloc_final(2, &mlbdd_pair_finalize);
  PairSet_val(result) = pairs;

  return result;
}
Exemplo n.º 6
0
Arquivo: muddy.c Projeto: Armael/HOL
static void mlbdd_freegcstrings() {
  if(printgc) {
    stat_free(pregc);
    stat_free(postgc);
    printgc = 0;
  }
}
Exemplo n.º 7
0
/* Fill a preallocated vector arguments, doing expansion and all.
 * Assumes Tcl will
 *  not tamper with our strings
 *  make copies if strings are "persistent"
 */
int fill_args (char **argv, int where, value v)
{
  value l;

  switch (Tag_val(v)) {
  case 0:
    argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
    return (where + 1);
  case 1:
    for (l=Field(v,0); Is_block(l); l=Field(l,1))
      where = fill_args(argv,where,Field(l,0));
    return where;
  case 2:
    { char **tmpargv;
      char *merged;
      int i;
      int size = argv_size(Field(v,0));
      tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
      fill_args(tmpargv,0,Field(v,0));
      tmpargv[size] = NULL;
      merged = Tcl_Merge(size,tmpargv);
      for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
      stat_free((char *)tmpargv);
      /* must be freed by stat_free */
      argv[where] = (char*)stat_alloc(strlen(merged)+1);
      strcpy(argv[where], merged);
      Tcl_Free(merged);
      return (where + 1);
    }
  default:
    tk_error("fill_args: illegal tag");
  }
}
Exemplo n.º 8
0
Arquivo: win32.c Projeto: OpenXT/ocaml
CAMLprim value caml_thread_new(value clos)
{
  caml_thread_t th;
  value vthread = Val_unit;
  value descr;
  DWORD th_id;

  Begin_roots2 (clos, vthread)
    /* Create a finalized value to hold thread handle */
    vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
                          caml_thread_finalize, 1, 1000);
    ((struct caml_thread_handle *)vthread)->handle = NULL;
    /* Create a descriptor for the new thread */
    descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
    Ident(descr) = Val_long(thread_next_ident);
    Start_closure(descr) = clos;
    Threadhandle(descr) = (struct caml_thread_handle *) vthread;
    thread_next_ident++;
    /* Create an info block for the current thread */
    th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
    th->descr = descr;
#ifdef NATIVE_CODE
    th->bottom_of_stack = NULL;
    th->exception_pointer = NULL;
    th->local_roots = NULL;
#else
    /* Allocate the stacks */
    th->stack_low = (value *) stat_alloc(Thread_stack_size);
    th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
    th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
    th->sp = th->stack_high;
    th->trapsp = th->stack_high;
    th->local_roots = NULL;
    th->external_raise = NULL;
    th->backtrace_pos = 0;
    th->backtrace_buffer = NULL;
    th->backtrace_last_exn = Val_unit;
#endif
    /* Add thread info block to the list of threads */
    th->next = curr_thread->next;
    th->prev = curr_thread;
    curr_thread->next->prev = th;
    curr_thread->next = th;
    /* Fork the new thread */
    th->wthread =
      CreateThread(NULL, 0, caml_thread_start, (void *) th, 0, &th_id);
    if (th->wthread == NULL) {
      /* Fork failed, remove thread info block from list of threads */
      th->next->prev = curr_thread;
      curr_thread->next = th->next;
#ifndef NATIVE_CODE
      stat_free(th->stack_low);
#endif
      stat_free(th);
      caml_wthread_error("Thread.create");
    }
    ((struct caml_thread_handle *)vthread)->handle = th->wthread;
  End_roots();
  return descr;
}
Exemplo n.º 9
0
void set_minor_heap_size (size_t size)
{
  char *new_heap;
  value **new_table;

  assert (size >= Minor_heap_min);
  assert (size <= Minor_heap_max);
  assert (size % sizeof (value) == 0);
  if (young_ptr != young_start) minor_collection ();
  assert (young_ptr == young_start);
  new_heap = (char *) stat_alloc (size);
  if (young_start != NULL){
    stat_free ((char *) young_start);
  }
  young_start = new_heap;
  young_end = new_heap + size;
  young_ptr = young_start;
  minor_heap_size = size;

  ref_table_size = minor_heap_size / sizeof (value) / 8;
  ref_table_reserve = 256;
  new_table = (value **) stat_alloc ((ref_table_size + ref_table_reserve)
				     * sizeof (value *));
  if (ref_table != NULL) stat_free ((char *) ref_table);
  ref_table = new_table;
  ref_table_ptr = ref_table;
  ref_table_threshold = ref_table + ref_table_size;
  ref_table_limit = ref_table_threshold;
  ref_table_end = ref_table + ref_table_size + ref_table_reserve;
}
Exemplo n.º 10
0
static void caml_thread_remove_info(caml_thread_t th)
{
  if (th->next == th) all_threads = NULL; /* last Caml thread exiting */
  th->next->prev = th->prev;
  th->prev->next = th->next;
#ifndef NATIVE_CODE
  stat_free(th->stack_low);
#endif
  if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
  stat_free(th);
}
Exemplo n.º 11
0
CAMLprim value ml_gsl_odeiv_free_system(value vsyst)
{
  gsl_odeiv_system *syst = ODEIV_SYSTEM_VAL(vsyst);
  struct mlgsl_odeiv_params *p = syst->params;
  remove_global_root(&(p->closure));
  remove_global_root(&(p->jac_closure));
  remove_global_root(&(p->arr1));
  remove_global_root(&(p->arr2));
  remove_global_root(&(p->mat));
  stat_free(p);
  stat_free(syst);
  return Val_unit;
}
Exemplo n.º 12
0
CAMLprim value unix_execve(value path, value args, value env)
{
  char ** argv;
  char ** envp;
  argv = cstringvect(args);
  envp = cstringvect(env);
  (void) execve(String_val(path), argv, envp);
  stat_free((char *) argv);
  stat_free((char *) envp);
  uerror("execve", path);
  return Val_unit;                  /* never reached, but suppress warnings */
                                /* from smart compilers */
}
Exemplo n.º 13
0
value caml_mpi_allgather(value sendbuf,
                         value recvbuf, value recvlengths,
                         value comm)
{
  int * recvcounts, * displs;

  caml_mpi_counts_displs(recvlengths, &recvcounts, &displs);
  MPI_Allgatherv(String_val(sendbuf), string_length(sendbuf), MPI_BYTE,
                 String_val(recvbuf), recvcounts, displs, MPI_BYTE,
                 Comm_val(comm));
  stat_free(recvcounts);
  stat_free(displs);
  return Val_unit;
}
Exemplo n.º 14
0
CAMLprim value unix_execvpe(value path, value args, value env)
{
  char ** argv;
  char ** saved_environ;
  argv = cstringvect(args);
  saved_environ = environ;
  environ = cstringvect(env);
  (void) execvp(String_val(path), argv);
  stat_free((char *) argv);
  stat_free((char *) environ);
  environ = saved_environ;
  uerror("execvp", path);
  return Val_unit;                  /* never reached, but suppress warnings */
                                /* from smart compilers */
}
Exemplo n.º 15
0
void realloc_stack()
{
  size_t size;
  value * new_low, * new_high, * new_sp;
  value * p;

  assert(extern_sp >= stack_low);
  size = stack_high - stack_low;
  if (size >= Max_stack_size)
    raise_out_of_memory();
  size *= 2;
  gc_message ("Growing stack to %ld kB.\n",
	      (long) size * sizeof(value) / 1024);
  new_low = (value *) stat_alloc(size * sizeof(value));
  new_high = new_low + size;

#define shift(ptr) \
    ((char *) new_high - ((char *) stack_high - (char *) (ptr)))

  new_sp = (value *) shift(extern_sp);
  memmove((char *)new_sp, (char *)extern_sp, (stack_high - extern_sp) * sizeof(value));
  stat_free((char *) stack_low);
  trapsp = (value *) shift(trapsp);
  for (p = trapsp; p < new_high; p = Trap_link(p))
    Trap_link(p) = (value *) shift(Trap_link(p));
  stack_low = new_low;
  stack_high = new_high;
  stack_threshold = stack_low + Stack_threshold / sizeof (value);
  extern_sp = new_sp;

#undef shift
}
Exemplo n.º 16
0
Arquivo: ints.c Projeto: useada/mosml
value format_int(value fmt, value arg)      /* ML */
{
    char format_buffer[32];
    int prec;
    char * p;
    char * dest;
    value res;

    prec = 32;
    for (p = String_val(fmt); *p != 0; p++) {
        if (*p >= '0' && *p <= '9') {
            prec = atoi(p) + 5;
            break;
        }
    }
    if (prec <= sizeof(format_buffer)) {
        dest = format_buffer;
    } else {
        dest = stat_alloc(prec);
    }
    sprintf(dest, String_val(fmt), Long_val(arg));
    res = copy_string(dest);
    if (dest != format_buffer) {
        stat_free(dest);
    }
    return res;
}
Exemplo n.º 17
0
void caml_mpi_commit_floatarray(double * d, value data, mlsize_t len)
{
  if (d != NULL) {
    bcopy(d, (double *) data, len * sizeof(double));
    stat_free(d);
  }
}
Exemplo n.º 18
0
static void caml_thread_reinitialize(void)
{
  caml_thread_t thr, next;
  struct channel * chan;

  /* Remove all other threads (now nonexistent)
     from the doubly-linked list of threads */
  thr = curr_thread->next;
  while (thr != curr_thread) {
    next = thr->next;
    stat_free(thr);
    thr = next;
  }
  curr_thread->next = curr_thread;
  curr_thread->prev = curr_thread;
  all_threads = curr_thread;
  /* Reinitialize the master lock machinery,
     just in case the fork happened while other threads were doing
     leave_blocking_section */
  st_masterlock_init(&caml_master_lock);
  /* Tick thread is not currently running in child process, will be
     re-created at next Thread.create */
  caml_tick_thread_running = 0;
  /* Destroy all IO mutexes; will be reinitialized on demand */
  for (chan = caml_all_opened_channels;
       chan != NULL;
       chan = chan->next) {
    if (chan->mutex != NULL) {
      st_mutex_destroy(chan->mutex);
      chan->mutex = NULL;
    }
  }
}
Exemplo n.º 19
0
CAMLprim value netsys_openat(value dirfd, value path, value flags, value perm)
{
#ifdef HAVE_AT
    CAMLparam4(dirfd, path, flags, perm);
    int ret, cv_flags;
    char * p;

    /* shamelessly copied from ocaml distro */
    cv_flags = convert_flag_list(flags, open_flag_table);
    p = stat_alloc(string_length(path) + 1);
    strcpy(p, String_val(path));
    enter_blocking_section();
    ret = openat(Int_val(dirfd), p, cv_flags, Int_val(perm));
    leave_blocking_section();
    stat_free(p);
    if (ret == -1) uerror("openat", path);
#if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC)
    if (convert_flag_list(flags, open_cloexec_table) != 0) {
        int flags = fcntl(Int_val(dirfd), F_GETFD, 0);
        if (flags == -1 || fcntl(Int_val(dirfd), F_SETFD, flags | FD_CLOEXEC) == -1)
          uerror("openat", path);
    }
#endif
    CAMLreturn (Val_int(ret));
#else
    invalid_argument("Netsys_posix.openat not available");
#endif
}
Exemplo n.º 20
0
value caml_mpi_scatter(value sendbuf, value sendlengths, 
                       value recvbuf,
                       value root, value comm)
{
  int * sendcounts, * displs;

  caml_mpi_counts_displs(sendlengths, &sendcounts, &displs);
  MPI_Scatterv(String_val(sendbuf), sendcounts, displs, MPI_BYTE,
               String_val(recvbuf), string_length(recvbuf), MPI_BYTE,
               Int_val(root), Comm_val(comm));
  if (sendcounts != NULL) {
    stat_free(sendcounts);
    stat_free(displs);
  }
  return Val_unit;
}
Exemplo n.º 21
0
Arquivo: floats.c Projeto: Athas/mosml
value format_float(value fmt, value arg)    /* ML */
{
  char format_buffer[64];
  int prec, i;
  char * p;
  char * dest;
  value res;

  prec = 64;
  for (p = String_val(fmt); *p != 0; p++) {
    if (*p >= '0' && *p <= '9') {
      i = atoi(p) + 15;
      if (i > prec) prec = i;
      break;
    }
  }
  for( ; *p != 0; p++) {
    if (*p == '.') {
      i = atoi(p+1) + 15;
      if (i > prec) prec = i;
      break;
    }
  }
  if (prec <= sizeof(format_buffer)) {
    dest = format_buffer;
  } else {
    dest = stat_alloc(prec);
  }
  sprintf(dest, String_val(fmt), Double_val(arg));
  res = copy_string(dest);
  if (dest != format_buffer) {
    stat_free(dest);
  }
  return res;
}
Exemplo n.º 22
0
/*
 * Calling Tcl from Caml
 *   this version works on an arbitrary Tcl command,
 *   and does parsing and substitution
 */
CAMLprim value camltk_tcl_eval(value str)
{
  int code;
  char *cmd = NULL;

  CheckInit();

  /* Tcl_Eval may write to its argument, so we take a copy
   * If the evaluation raises a Caml exception, we have a space
   * leak
   */
  Tcl_ResetResult(cltclinterp);
  cmd = caml_string_to_tcl(str);
  code = Tcl_Eval(cltclinterp, cmd);
  stat_free(cmd);

  switch (code) {
  case TCL_OK:
    return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp));
  case TCL_ERROR:
    tk_error(Tcl_GetStringResult(cltclinterp));
  default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
    tk_error("bad tcl result");
  }
}
Exemplo n.º 23
0
CAMLexport char * caml_search_exe_in_path(char * name)
{
  char * fullname, * filepart;
  DWORD pathlen, retcode;

  pathlen = strlen(name) + 1;
  if (pathlen < 256) pathlen = 256;
  while (1) {
    fullname = stat_alloc(pathlen);
    retcode = SearchPath(NULL,              /* use system search path */
			 name,
			 ".exe",            /* add .exe extension if needed */
			 pathlen,
			 fullname,
			 &filepart);
    if (retcode == 0) {
      caml_gc_message(0x100, "%s not found in search path\n",
		      (uintnat) name);
      strcpy(fullname, name);
      break;
    }
    if (retcode < pathlen) break;
    stat_free(fullname);
    pathlen = retcode + 1;
  }
  return fullname;
}
Exemplo n.º 24
0
CAMLprim value ml_gsl_min_fminimizer_free(value s)
{
  remove_global_root(&(Mparams_val(s)->closure));
  stat_free(Mparams_val(s));
  gsl_min_fminimizer_free(Minimizer_val(s));
  return Val_unit;
}
Exemplo n.º 25
0
Arquivo: ml_gdk.c Projeto: CRogers/obc
CAMLprim value ml_gdk_gc_set_dashes(value gc, value offset, value dashes)
{
  CAMLparam3(gc, offset, dashes);
  CAMLlocal1(tmp);
  int l = 0;
  int i;
  gint8 *cdashes;
  for(tmp = dashes; tmp != Val_int(0); tmp = Field(tmp,1)){
    l++;
  }
  if( l == 0 ){ ml_raise_gdk("line dashes must have at least one element"); }
  cdashes = stat_alloc(sizeof (gint8) * l);
  for(i=0, tmp= dashes; i<l; i++, tmp = Field(tmp,1)){
    int d;
    d = Int_val(Field(tmp,0));
    if( d<0 || d>255 ){
      stat_free (cdashes);
      ml_raise_gdk("line dashes must be [0..255]");
    }
    cdashes[i] = d;
  }
  gdk_gc_set_dashes( GdkGC_val(gc), Int_val(offset), cdashes, l);
  /* stat_free (cdashes); ? */
  CAMLreturn(Val_unit);
}
Exemplo n.º 26
0
value format_int(value fmt, value arg)
{
	char format_buffer[32];
	size_t prec;
	char * p;
	char * dest;
	value res;

	prec = 32;
	for (p = String_val(fmt); *p != 0; p++) {
		if (*p >= '0' && *p <= '9') {
			prec = strtoul(p, NULL, 10);
			break;
		}
	}

	if (prec <= sizeof(format_buffer)) {
		dest = format_buffer;
	} else {
		dest = stat_alloc(prec);
	}
	sprintf(dest, String_val(fmt), VAL_TO_LONG(arg));
	res = copy_string(dest);
	if (dest != format_buffer) {
		stat_free(dest);
	}

	return res;
}
Exemplo n.º 27
0
value caml_mpi_gather(value sendbuf,
                      value recvbuf, value recvlengths,
                      value root, value comm)
{
  int * recvcounts, * displs;

  caml_mpi_counts_displs(recvlengths, &recvcounts, &displs);
  MPI_Gatherv(String_val(sendbuf), string_length(sendbuf), MPI_BYTE,
              String_val(recvbuf), recvcounts, displs, MPI_BYTE,
              Int_val(root), Comm_val(comm));
  if (recvcounts != NULL) {
    stat_free(recvcounts);
    stat_free(displs);
  }
  return Val_unit;
}
Exemplo n.º 28
0
value caml_mpi_cart_create(value comm, value vdims, value vperiods,
                           value reorder)
{
  int ndims = Wosize_val(vdims);
  int * dims = stat_alloc(ndims * sizeof(int));
  int * periods = stat_alloc(ndims * sizeof(int));
  int i;
  MPI_Comm newcomm;

  for (i = 0; i < ndims; i++) dims[i] = Int_val(Field(vdims, i));
  for (i = 0; i < ndims; i++) periods[i] = Int_val(Field(vperiods, i));
  MPI_Cart_create(Comm_val(comm), ndims, dims, periods, 
                  Bool_val(reorder), &newcomm);
  stat_free(dims);
  stat_free(periods);
  return caml_mpi_alloc_comm(newcomm);
}
Exemplo n.º 29
0
value caml_mpi_group_translate_ranks(value group1, value ranks, value group2)
{
  int n = Wosize_val(ranks);
  int * ranks1 = stat_alloc(n * sizeof(int));
  int * ranks2 = stat_alloc(n * sizeof(int));
  int i;
  value res;

  for (i = 0; i < n; i++) ranks1[i] = Int_val(Field(ranks, i));
  MPI_Group_translate_ranks(Group_val(group1), n, ranks1,
                            Group_val(group2), ranks2);
  res = alloc(n, 0);
  for (i = 0; i < n; i++) Field(res, i) = Val_int(ranks2[i]);
  stat_free(ranks1);
  stat_free(ranks2);
  return res;
}
Exemplo n.º 30
0
CAMLprim value ml_gsl_monte_plain_free(value s)
{
    remove_global_root(&(CallbackParams_val(s)->closure));
    remove_global_root(&(CallbackParams_val(s)->dbl));
    stat_free(CallbackParams_val(s));
    gsl_monte_plain_free(GSLPLAINSTATE_VAL(s));
    return Val_unit;
}