Parallel CAML

Parallel CAML

[Daniel de Rauglaudre]

I send here the files for my implementation of continuations in caml-light.
Without warranty: it's a prototype!

	Daniel de Rauglaudre
	ddr@margaux.inria.fr

#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 12/21/1992 16:19 UTC by ddr@margaux
# Source directory /home/margaux/formel1/ddr/scratch/tmp
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#    353 -rw-r--r-- Makefile
#    697 -rw-rw-r-- README
#   6341 -rw-r--r-- callcc.c
#    299 -rw-r--r-- callcc.ml
#    601 -rw-r--r-- callcc.mli
#     70 -rwxr-xr-x camltop
#   1015 -rw-r--r-- concur.ml
#    109 -rw-rw-r-- example.ml
#
# ============= Makefile ==============
if test -f 'Makefile' -a X"$1" != X"-c"; then
	echo 'x - skipping Makefile (File already exists)'
else
echo 'x - extracting Makefile (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'Makefile' &&
CAMLTOP=caml-light
CFLAGS=-I$(CAMLTOP)/src/runtime -UNDEBUG -O
CAMLMKTOP=camlmktop
X
all: camltop.out callcc.zo
X
camltop.out: callcc.zo callcc.o
X	$(CAMLMKTOP) -custom callcc.zo callcc.o $(UNIX)
X
clean:
X	rm -f *.o *.zi *.zo *.out *.bak *~
X
.mli.zi:
X	camlc -c $(ZFLAGS) $<
X
.ml.zo:
X	camlc -c $(ZFLAGS) $<
X
.SUFFIXES: .mli .zi .ml .zo
X
callcc.zo: callcc.zi
SHAR_EOF
chmod 0644 Makefile ||
echo 'restore of Makefile failed'
Wc_c="`wc -c < 'Makefile'`"
test 353 -eq "$Wc_c" ||
	echo 'Makefile: original size 353, current size' "$Wc_c"
fi
# ============= README ==============
if test -f 'README' -a X"$1" != X"-c"; then
	echo 'x - skipping README (File already exists)'
else
echo 'x - extracting README (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'README' &&
To make a toplevel holding the continuations functions:
X
1- Edit the file "Makefile":
X
  Set the variable CAMLTOP to the main directory of the distribution
of Caml-Light 0.5. This was necessary because some usefull include files are
not installed in the standard caml-light library (/usr/local/lib/caml-light).
X
2- Run "make"
X
  This compiles callcc.c, callcc.ml, callcc.mli and creates the toplevel
camltop.out.
X
X
To execute this toplevel, just type: ./camltop
X
X
There is a small test in "example.ml".
See also the file "concur.ml" for a small implementation of coroutines
using channels.
X
X
This files are given without warranty. This is a prototype.
X
X	Daniel de Rauglaudre
X	ddr@margaux.inria.fr
SHAR_EOF
chmod 0664 README ||
echo 'restore of README failed'
Wc_c="`wc -c < 'README'`"
test 697 -eq "$Wc_c" ||
	echo 'README: original size 697, current size' "$Wc_c"
fi
# ============= callcc.c ==============
if test -f 'callcc.c' -a X"$1" != X"-c"; then
	echo 'x - skipping callcc.c (File already exists)'
else
echo 'x - extracting callcc.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'callcc.c' &&
/* $Id: callcc.c,v 1.11 92/12/21 11:59:52 ddr Exp $ */
X
#include <assert.h>
#ifndef NDEBUG
#include <stdio.h>
#define private
#define public
#else
#define private static
#define public
#endif
X
#define Setup_for_gc
#define Restore_after_gc
#include "mlvalues.h"
#include "stacks.h"
#include "prims.h"
#include "memory.h"
X
#define ret(sp)		((struct return_frame *) (sp))
#define rsp		extern_rsp
#define asp		extern_asp
X
private unsigned long min_as_size = 0, min_rs_size = 0;
private int trace_if_major = 1;
X
#undef CONTCNT
#ifdef CONTCNT
private int cont_cnt = 0;
#endif
X
#undef CONTSZ
#ifdef CONTSZ
private int cont_max_size = 0;
#endif
X
#undef TRACE
X
public value save_cont (v)
value v;
{
X	int size_in_longs;
X	register value *p, *q;
X	value *r;
X	value *arg_stack_start = arg_stack_high - min_as_size;
X	value *ret_stack_start = ret_stack_high - min_rs_size;
X	int arg_stack_len = arg_stack_start - asp;
X	int ret_stack_len = ret_stack_start - rsp;
/* bogus mark any address not in the heap */
#define BOGUSMARK	((value) save_cont)
X
X	assert (c_roots_head == NULL);;
X
X	if (arg_stack_len < 0 || ret_stack_len < 0)
X		failwith ("callcc: incorrect stack start");
X	size_in_longs = 3 + arg_stack_len + ret_stack_len;
#ifdef CONTCNT
X	size_in_longs++;
X	printf ("callcc: save cont no %d\n", cont_cnt);
#endif
#if 0
X	printf ("callcc: continuation size (in longs) = %d\n", size_in_longs);
#endif
#ifdef CONTSZ
X	if (size_in_longs > cont_max_size) {
X		cont_max_size = size_in_longs;
X		printf ("callcc: max cont size so far = %d\n", cont_max_size);
X	}
#endif
        if (size_in_longs < Max_young_wosize) {
X		value accu;
X		Alloc_small (accu, size_in_longs, 0);
X		r = (value *) accu;
X	}
X	else {
X		if (trace_if_major)
X			printf ("**** continuation allocated in MAJOR heap\n");
X		Setup_for_gc;
X		minor_collection ();
X		r = (value *) alloc_shr (size_in_longs, 0);
X		Restore_after_gc;
X	}
X	p = r;
X
#ifdef CONTCNT
X	*p++ = Val_long (cont_cnt++);
#endif
X	/* save sizes of arg & ret & tp stacks */
#ifdef TRACE
X	printf ("callcc: arg stack size = %d\n", arg_stack_len);
X	printf ("callcc: ret stack size = %d\n", ret_stack_len);
X	printf ("callcc: relative tp = %d\n", ret_stack_start - (value *) tp);
#endif
X	*p++ = Val_long (arg_stack_len);
X	*p++ = Val_long (ret_stack_len);
X	*p++ = Val_long (ret_stack_start - (value *) tp);
X
X	/* save arg stack; mind the MARKs! */
X	for (q = asp; q < arg_stack_start; p++, q++) {
X		if (*q == MARK) *p = BOGUSMARK;
#ifndef NDEBUG
X		else if (*q == BOGUSMARK) {
X			printf ("*** quel est le fils de pute ?\n");
X			exit (1);
X		}
#endif
X		else *p = *q;
X	}
X
X	/* save ret stack */
X	for (q = rsp; q < ret_stack_start; ) {
X		int i = ret(q)->cache_size;
X		ret(p)->env = ret(q)->env;
X		ret(p)->pc = (code_t) Val_long(ret(q)->pc);
X		ret(p)->cache_size = Val_long(i);
X		q += sizeof(struct return_frame)/sizeof(value);
X		p += sizeof(struct return_frame)/sizeof(value);
X		while (--i >= 0) *p++ = *q++;
X	}
X	assert (q == ret_stack_start);
X	assert (p == r + 3 + arg_stack_len + ret_stack_len);
#ifdef TRACE
X	printf ("callcc: terminated ok\n");
#endif
X
X	return (value) r;
}
X
public value restore_cont (k, v)
value k, v;
{
X	register value *p, *q;
X	value *arg_stack_start = arg_stack_high - min_as_size;
X	value *ret_stack_start = ret_stack_high - min_rs_size;
X	int cache_size = ret(rsp)->cache_size;
X
X	assert (c_roots_head == NULL);;
X
X	p = (value *) k;
X
#ifdef CONTCNT
X	printf ("throw: restore cont no %d\n", Long_val (*p++));
#endif
X
X	/* restore positions of arg & ret & tp stacks */
X	asp = arg_stack_start - Long_val (*p++);
X	rsp = ret_stack_start - Long_val (*p++);
X	tp = (struct trap_frame *) (ret_stack_start - Long_val (*p++));
#ifdef TRACE
X	printf ("throw: arg stack size = %d\n", arg_stack_start - asp);
X	printf ("throw: ret stack size = %d\n", ret_stack_start - rsp);
X	printf ("throw: relative tp = %d\n", ret_stack_start - (value *) tp);
#endif
X
X	/* restore arg stack */
X	for (q = asp; q < arg_stack_start; p++, q++) {
X		if (*p == BOGUSMARK) *q = MARK;
X		else *q = *p;
X	}
X
X	/* restore ret stack */
X	for (q = rsp; q < ret_stack_start; ) {
X		int i = Long_val (ret(p)->cache_size);
X		ret(q)->env = ret(p)->env;
X		ret(q)->pc = (code_t) Long_val ((value) ret(p)->pc);
X		ret(q)->cache_size = i;
X		p += sizeof(struct return_frame)/sizeof(value);
X		q += sizeof(struct return_frame)/sizeof(value);
X		while (--i >= 0) *q++ = *p++;
X	}
X	assert (q == ret_stack_start);
X	assert (p == (value *) k + 3 + (arg_stack_start - asp) + (ret_stack_start - rsp));
X
X	if (cache_size != ret(rsp)->cache_size) {
X		value env = ret(rsp)->env;
X		rsp -= (cache_size - ret(rsp)->cache_size);
X		ret(rsp)->env = env;
X	}
#if 1
X	if (*asp != MARK)
X		printf ("hmm... asp != MARK\n");
#endif
X	asp--; /* not actually a pop: just because C_CALL2 adds 1 to asp */
#ifdef TRACE
X	printf ("throw: terminated ok\n");
#endif
X	return v;
}
X
public value new_stack (v)
value v;
{
X	/* 2 frames on ret stack given:
X	   - 1 for returning from C
X	   - 1 for possible throw of this stack (throw uses normal return)
X	*/
X	int c_cache_size = ret(rsp)->cache_size;
X	int c_len = sizeof(struct return_frame)/sizeof(value) + c_cache_size;
X	int ml_cache_size = ret(rsp + c_len)->cache_size;
X	int ml_len = sizeof(struct return_frame)/sizeof(value) + ml_cache_size;
X	value len = c_len + ml_len;
X	value *src = rsp + len;
X
#if 0
X	printf ("new_stack: c_cache_size = %d\n", c_cache_size);
X	printf ("new_stack: ml_cache_size = %d\n", ml_cache_size);
#endif
X	asp = arg_stack_high;
X	rsp = ret_stack_high;
X	tp = (struct trap_frame *) ret_stack_high;
X	while (--len >= 0) *--rsp = *--src;
#ifdef TRACE
X	printf ("new_stack: terminated ok\n");
#endif
X	return v;
}
X
public value get_stack_pos (v)
value v;
{
        value ms;
        Alloc_small (ms, 2, 0);
        Field (ms, 0) = Val_long (arg_stack_high - asp);
        Field (ms, 1) = Val_long (ret_stack_high - rsp
X		- sizeof (struct return_frame) / sizeof (value)
X		- ret(rsp)->cache_size);
X	return ms;
}
X
public value get_min_cont (v)
value v;
{
        value ms;
        Alloc_small (ms, 2, 0);
        Field (ms, 0) = Val_long (min_as_size);
        Field (ms, 1) = Val_long (min_rs_size);
X	return ms;
}
X
public value set_min_cont (ms)
value ms;
{
        min_as_size = Long_val (Field (ms, 0));
        min_rs_size = Long_val (Field (ms, 1));
        return Atom (0);
}
X
public value set_trace_major (b)
value b;
{
X	trace_if_major = (b != Atom(0));
X	return Atom(0);
}
SHAR_EOF
chmod 0644 callcc.c ||
echo 'restore of callcc.c failed'
Wc_c="`wc -c < 'callcc.c'`"
test 6341 -eq "$Wc_c" ||
	echo 'callcc.c: original size 6341, current size' "$Wc_c"
fi
# ============= callcc.ml ==============
if test -f 'callcc.ml' -a X"$1" != X"-c"; then
	echo 'x - skipping callcc.ml (File already exists)'
else
echo 'x - extracting callcc.ml (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'callcc.ml' &&
(* $Id: callcc.ml,v 1.11 92/12/21 11:59:55 ddr Exp $ *)
X
let callcc f =
  f (save_cont ())
;;
X
let throw =
  restore_cont
;;
X
let handle_cont f a =
  let mc = get_min_cont () in
  set_min_cont (get_stack_pos ());
  let x =
    try f a with x -> set_min_cont mc; raise x
  in
  set_min_cont mc; x
;;
SHAR_EOF
chmod 0644 callcc.ml ||
echo 'restore of callcc.ml failed'
Wc_c="`wc -c < 'callcc.ml'`"
test 299 -eq "$Wc_c" ||
	echo 'callcc.ml: original size 299, current size' "$Wc_c"
fi
# ============= callcc.mli ==============
if test -f 'callcc.mli' -a X"$1" != X"-c"; then
	echo 'x - skipping callcc.mli (File already exists)'
else
echo 'x - extracting callcc.mli (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'callcc.mli' &&
(* $Id: callcc.mli,v 1.13 92/12/21 11:59:57 ddr Exp $ *)
X
type 'a cont;;
X
value callcc : ('a cont -> 'a) -> 'a;;
value throw : 'a cont -> 'a -> 'b;;
value handle_cont : ('a -> 'b) -> 'a -> 'b;;
value new_stack : unit -> unit = 1 "new_stack";;
X
value save_cont : unit -> 'a cont = 1 "save_cont";;
value restore_cont : 'a cont -> 'a -> 'b = 2 "restore_cont";;
value get_stack_pos : unit -> int * int = 1 "get_stack_pos";;
value get_min_cont : unit -> int * int = 1 "get_min_cont";;
value set_min_cont : int * int -> unit = 1 "set_min_cont";;
value set_trace_major : bool -> unit = 1 "set_trace_major";;
SHAR_EOF
chmod 0644 callcc.mli ||
echo 'restore of callcc.mli failed'
Wc_c="`wc -c < 'callcc.mli'`"
test 601 -eq "$Wc_c" ||
	echo 'callcc.mli: original size 601, current size' "$Wc_c"
fi
# ============= camltop ==============
if test -f 'camltop' -a X"$1" != X"-c"; then
	echo 'x - skipping camltop (File already exists)'
else
echo 'x - extracting camltop (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'camltop' &&
#!/bin/sh -e
X
exec ./camltop.out -stdlib /usr/local/lib/caml-light $*
SHAR_EOF
chmod 0755 camltop ||
echo 'restore of camltop failed'
Wc_c="`wc -c < 'camltop'`"
test 70 -eq "$Wc_c" ||
	echo 'camltop: original size 70, current size' "$Wc_c"
fi
# ============= concur.ml ==============
if test -f 'concur.ml' -a X"$1" != X"-c"; then
	echo 'x - skipping concur.ml (File already exists)'
else
echo 'x - extracting concur.ml (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'concur.ml' &&
(* $Id: concur.ml,v 1.9 92/09/07 14:51:05 ddr Exp $ *)
X
#open "callcc";;
X
type 'a option = None | Some of 'a;;
let queue_get q =
  try Some (queue__take q) with queue__Empty -> None
;;
X
type 'a chan = {
  inq  : 'a cont queue__t;
  outq : ('a * unit cont) queue__t
};;
X
let rdyQ = (queue__new () : unit cont queue__t);;
let channel () = {inq = queue__new (); outq = queue__new ()};;
X
let spawn f =
  callcc (fun parent_k ->
    queue__add parent_k rdyQ;
    f ();
    throw (queue__take rdyQ) ()
  )
;;
X
let send ch msg =
  callcc (fun send_k ->
    match queue_get ch.inq with
      Some accept_k ->
        queue__add send_k rdyQ;
        throw accept_k msg
    | None ->
        queue__add (msg, send_k) ch.outq;
        throw (queue__take rdyQ) ()
  )
;;
X
let accept ch =
  callcc (fun accept_k ->
    match queue_get ch.outq with
      Some (msg, send_k) ->
        queue__add send_k rdyQ;
        throw accept_k msg
    | None ->
        queue__add accept_k ch.inq;
        throw (queue__take rdyQ) ()
  )
;;
SHAR_EOF
chmod 0644 concur.ml ||
echo 'restore of concur.ml failed'
Wc_c="`wc -c < 'concur.ml'`"
test 1015 -eq "$Wc_c" ||
	echo 'concur.ml: original size 1015, current size' "$Wc_c"
fi
# ============= example.ml ==============
if test -f 'example.ml' -a X"$1" != X"-c"; then
	echo 'x - skipping example.ml (File already exists)'
else
echo 'x - extracting example.ml (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'example.ml' &&
#open "callcc";;
let test a = callcc (fun k -> 3 + (if a then 1 else throw k 10));;
test true;;
test false;;
SHAR_EOF
chmod 0664 example.ml ||
echo 'restore of example.ml failed'
Wc_c="`wc -c < 'example.ml'`"
test 109 -eq "$Wc_c" ||
	echo 'example.ml: original size 109, current size' "$Wc_c"
fi
exit 0

Re: Parallel CAML

[Daniel de Rauglaudre]

> We're thinking of doing some experiments using CAML as the
> basis for a parallel distributed system.  (It's only in the
> early stages at present, so don't ask me how!!)  Is anyone
> else doing anything with CAML and parallelism?  I'd be
> especially interested in anyone who's ported Reppy's
> Comcurrent ML constructs, but anything to do with parallel
> execution would be of interest.

I implemented the continuations functions, a` la SML: "callcc" and "throw" 
in Caml-Light. I read Reppy's thesis. I just implemented his basic functions
"channel", "spawn", "send" et "accept" in Caml-Light using continuations.

This implementation of continuations is compatible with Caml-Light
version 0.5 on unix machines. No modification of the runtime is
necessary, just a link with a C program. The functions "callcc" and
"throw" are normal C functions, called from Caml-Light.

	Daniel de Rauglaudre
	ddr@margaux.inria.fr

Parallel CAML

[sd]

Hi everyone

We're thinking of doing some experiments using CAML as the
basis for a parallel distributed system.  (It's only in the
early stages at present, so don't ask me how!!)  Is anyone
else doing anything with CAML and parallelism?  I'd be
especially interested in anyone who's ported Reppy's
Comcurrent ML constructs, but anything to do with parallel
execution would be of interest.

Thanks in advance,


-- Si

Simon A. Dobson

Informatics Department              \  If I'd the knack
SERC Rutherford Appleton Laboratory  \   I'd sing like
Chilton, Didcot, Oxon OX11 0QX, UK.   \    Cherry flakes falling

(+44 235) 445478    sd@inf.rl.ac.uk