Exercises

Exercises

Polymorphic Printing Function

We wish to define a printing function print with type 'a -> unit able to print any Objective CAML value. To this end, we extend and improve the inspect function.

In C, write the function print_ws which prints Objective CAML as follows:

immediate values: as C integers;
strings: between quotes;
floats: as usual;
arrays of floats: between [| |]
closures: as < code, env >
everything else: as a tuple, between ( )

The function should handle structured types recursively. A polymorphic printing function in C:

#include <stdio.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>

value print_ws (value v) {
  CAMLparam1(v);
  int size,i ;
  if (Is_long(v)) printf("%d", Long_val(v)); 
  else {
    size=Wosize_val(v);
    switch (Tag_val(v)) 
      {
      case String_tag :
 printf("\"%s\"", String_val(v));  
 break;
      case Double_tag:  
 printf("%g", Double_val(v));
 break;
      case Double_array_tag : 
 printf ("[|"); 
        if (size>0) printf("%g", Double_field(v,0));
 for (i=1;i<(size/Double_wosize);i++)  printf("; %g", Double_field(v,i));
 printf("|]");
 break;
      case Abstract_tag :
      case Custom_tag : 
 printf("<abstract>"); 
 break;
      case Closure_tag : 
 printf("<%d, ",Code_val(v)) ;
 if (size>1) print_ws(Field(v,1)) ;
 for (i=2;i<size;i++) {
   printf("; ") ;
   print_ws(Field(v,i));
 }
 printf(">");
 break;
      default:  
 if (Tag_val(v)>=No_scan_tag) printf("?"); 
 else {
   printf("(");
   if (size>0) print_ws(Field(v,0));
   for (i=1;i<size;i++) {
     printf(", ");
     print_ws(Field(v,i));
   }
   printf(")");
 }
      }
  }
  fflush(stdout);
  return Val_unit;
}

called from Objective CAML:


# external print_ws : 'a -> unit = "print_ws"  ;;
external print_ws : 'a -> unit = "print_ws"

To avoid looping on circular values, and to display sharing properly, modify this function to keep track of the addresses of heap blocks it has already seen. If an address appears several times, name it when it is first printed (v = name), and just print the name when this address is encountered again.


# type address ;;
type address

Define a data structure to record the addresses, determine when they occur several times, and associate a name with each address.


# let (gensym,init_gensym) =
   let i = ref 0 in
     (function () -> incr i ; "val_" ^ (string_of_int !i)) 
   , (function () -> i:=0) ;;
val gensym : unit -> string = <fun>
val init_gensym : unit -> unit = <fun>

# type occurrence = 
     Once
   | Several_times
   | Already_named of string ;;
type occurrence = | Once | Several_times | Already_named of string

# let table = ref ([] : (address * occurrence) list) ;;
val table : (address * occurrence) list ref = {contents=[]}


# let record addr = 
   try  
     match List.assq addr !table with
       Once -> table := (addr, Several_times) :: !table;
               true
     | _ -> true
   with
     Not_found -> table := (addr, Once) :: !table; false ;;
val record : address -> bool = <fun>


# let multiple_occ addr = 
   match List.assq addr !table with
     Once -> false
   | _ -> true ;;
val multiple_occ : address -> bool = <fun>


# let already_named addr = 
   match List.assq addr !table with
     Once -> failwith "already_named"
   | Several_times -> table := (addr, Already_named (gensym ())) :: !table;
                      false 
   | Already_named _ -> true ;;
val already_named : address -> bool = <fun>

# let name_of addr = 
   match List.assq addr !table with
     Already_named s -> s 
   | _ -> raise Not_found ;;
val name_of : address -> string = <fun>

Traverse the value once first to determine all the addresses it contains and record them in the data structure. La partie Objective CAML:


# Callback.register "add" ajoute ;;
- : unit = ()
# Callback.register "multiple?" multiple_occ ;;
- : unit = ()
# Callback.register "named?" already_named ;;
- : unit = ()
# Callback.register "name" name_of ;;
- : unit = ()

# external explore_value : 'a -> unit = "explore"  ;;
external explore_value : 'a -> unit = "explore"

The C part:

#include <caml/callback.h>

value explore (value v) {
  CAMLparam1(v);
  int size,i;
  if (Is_long(v)) return Val_unit;
  if (Bool_val(callback(*caml_named_value("add"), v))) return Val_unit;
  size=Wosize_val(v);
  switch (Tag_val(v)) 
    {
      case String_tag :
      case Double_tag:  
      case Double_array_tag : 
      case Abstract_tag :
      case Final_tag : 
        break;
      case Closure_tag : 
        for (i=1;i<size;i++) explore(Field(v,i));
        break;
      default:  
        if (Tag_val(v)>=No_scan_tag) break ;
        for (i=0;i<size;i++) explore(Field(v,i));
    }
  return Val_unit;
}

The second traversal prints the value while naming addresses at their first occurrences.


# external print_rec : 'a -> unit = "print_gen" ;;
external print_rec : 'a -> unit = "print_gen"

value print_gen (value v)
{
  CAMLparam1(v);
  int size,i ;
  if (Is_long(v))  return print_ws(v) ;
  if (Bool_val(callback(*caml_named_value("multiple?"),v))) {
    if (Bool_val(callback(*caml_named_value("named?"),v))) {
      printf("%s",String_val(callback(*caml_named_value("name"),v))) ;
      return Val_unit ;
    }
    printf("%s = { ",String_val(callback(*caml_named_value("name"),v))) ;
  }
  size=Wosize_val(v);
  switch (Tag_val(v)) 
    {
      case String_tag :
      case Double_tag:  
      case Double_array_tag : 
      case Abstract_tag :
      case Final_tag : 
 print_ws(v);
 break;
      case Closure_tag : 
 printf("<%d, ",Code_val(v)) ;
 if (size>1) print_gen(Field(v,1)) ;
 for (i=2;i<size;i++) {
   printf("; ") ;
   print_gen(Field(v,i));
 }
 printf(">");
 break;
      default:  
 if (Tag_val(v)>=No_scan_tag) printf("?"); 
 else {
   printf("(");
   if (size>0) print_gen(Field(v,0));
   for (i=1;i<size;i++) {
     printf(", ");
     print_gen(Field(v,i));
   }
   printf(")");
 }
    }
  if (Bool_val(callback(*caml_named_value("multiple?"),v)))  printf(" }") ; 
  fflush(stdout);
  return Val_unit;
}

Define the function print combining both traversals.
```
external print_rec : 'a -> unit = "print_gen" ;;
let print v = 
  table := [] ;
  init_gensym () ;
  explore_value v ;
  print_rec v ;
  table := [] ;;
```

Matrix Product

Define an abstract type float_matrix for matrices of floating-point numbers.
```
# type float_matrix ;;
type float_matrix
```
Define a C type for these matrices.
```
typedef struct { void (*finalization_function)(value) ;
                 int size_x , size_y ;
                 double * mat ;
               } Matrix ;
```

Write a C function to convert values of type float array array to values of type float_matrix.

static void finalize_matrix(value mat) {
  free(((Matrix *) mat)->mat);
}

static value alloc_matrix(int size_x,int size_y) {
  int byte_size ;
  Matrix * res ;
  vres=alloc(sizeof(Matrix)/sizeof(value),
             finalize_matrix, size_x*size_y, 1000000) ;
  res=(Matrix *) vres ;
  res->size_x = size_x ;
  res->size_y = size_y ;
  res->mat = malloc(size_x*size_y*sizeof(double)) ;
  return vres;
}

value conversion_to_C (value faa) {
  CAMLparam1(faa) ;
  CAMLlocal2(vres,vect) ;
  Matrix * res ;
  double * tab;
  int size_x, size_y, i, j ;

  /* size of the array of arrays */
  size_x = Wosize_val(faa) ;
  /* size of each array */
  if (size_x>0) size_y = Wosize_val(Field(faa,0))/2 ;

  /* allocate the value of type float_matrix */
  vres=alloc_matrix(size_x,size_y);
  res=(Matrix *) vres ;
  res->size_x = size_x ;
  res->size_y = size_y ;
  tab = res->mat;
  for (i=0;i<size_x;i++) {
    vect = Field(faa,i) ;
    if (Wosize_val(vect) != size_y)
      failwith("non-rectangular float array array") ;
    for (j=0;j<size_y;j++) *tab++ = Double_field(vect,j) ;
    }
  }
  CAMLreturn vres ;
}

Write a C function performing the reverse conversion.

value conversion_to_Caml (value matrix) {
  CAMLparam1(matrix) ;
  CAMLlocal2(res,aux) ;
  Matrix* mat = (Matrix *) matrix ;
  float * tab = mat->mat ;
  int i,j ;
  res=alloc(mat->size_x,0);
  for (i=0;i<mat->size_x;i++) {
    aux = alloc(mat->size_y*Double_wosize,Double_array_tag) ;
    Store_field(res,i,aux);
    for (j=0;j<mat->size_y;j++) Store_double_field(aux,j,*tab++) ;
  }
  CAMLreturn res ;
}

Add the C functions computing the sum and the product of these matrices.

value matrix_sum (value arg1,value arg2) {
  CAMLparam2(arg1,arg2) ;
  CAMLlocal1(vres) ;
  Matrix *m1=(Matrix*) arg1, *m2=(Matrix*) arg2, *res;
  int size,i;
  if (m1->size_x != m2->size_x || m1->size_y != m2->size_y)
    failwith("illegal matrix addition");
  vres=alloc_matrix(m1->size_x,m1->size_y);
  res =(Matrix*) vres;
  tab=vres->mat;
  size=m1->size_x*m1->size_y;
  for (i=0;i<size;i++) tab[i]=m1->mat[i]+m2->mat[i] ;
  CAMLreturn vres;
}

value matrix_product (value arg1,value arg2) {
  CAMLparam2(arg1,arg2) ;
  CAMLlocal1(vres) ;
  Matrix *m1=(Matrix*) arg1, *m2=(Matrix*) arg2, *res;
  int i,j,k;
  if (m1->size_y != m2->size_x) failwith("illegal matrix product");
  vres=alloc_matrix(m1->size_x,m2->size_y);
  for (i=0;i<res->size_x;i++) 
    for (j=0;j<res->size_y;j++) {
      double acc=0 ;
      for (k=0;k<m1->size_y;k++) 
 acc += m1->mat[i*m1->size_x+k] * m1->mat[k*m2->size_x+j] ;
      tab[i*m1->size_x+j]=acc ;
    }
  CAMLreturn vres;
}

Interface them with Objective CAML and use them.


# external to_matrix : float array array -> float_matrix = "conversion_to_C" ;;
# external of_matrix : float_matrix -> float array array = "conversion_to_Caml";;
# external sum : float_matrix -> float_matrix -> float_matrix = "matrix_add" ;;
# external prod : float_matrix -> float_matrix -> float_matrix = "matrix_product" ;;

Counting Words: Main Program in C

The Unix command wc counts the number of characters, words and lines in a file. The goal of this exercise is to implement this command, while counting repeated words only once.

Write the program wc in C. This program will simply count words, lines and characters in the file whose name is passed on the command line. Le fichier wc.c :

#include <stdio.h>

void read_file (char *path) {
  FILE *fd=fopen(path,"r");
  int chr=0;
  char buffer[80], *buff;
  int num_chr=0, nun_words=0, num_lines=0;

  if (fd == NULL) exit(2) ;
  buff=buffer ; *buff=0 ;
  while ((chr=getc(fd))!=EOF) {
    num_chr++ ;
    if (chr=='\n') num_lines++ ;
    if (chr==' ' || chr=='\n' ||(buff-buffer)>=80) {
      if (buff!=buffer) { num_words++; *buff=0; buff=buffer; }
    }
    else *(buff++)=chr; 
  }
  printf(" %d - %d - %d : %s\n",num_lines,num_words,num_chr,path);
}

int main (int argc,char **argv)
{
  if (argc>1) read_file(argv[1]);
  return 0;
}

Write in Objective CAML a function add_word that uses a hash table to record how many times the function was invoked with the same character string as argument.
```
# let table = Hashtbl.create 17 ;;
val table : ('_a, '_b) Hashtbl.t = <abstr>

# let add_word (w:string) = 
   try let p = Hashtbl.find table w in incr p 
   with Not_found -> Hashtbl.add table w (ref 1) ;;
val add_word : string -> unit = <fun>
```

Write two functions num_repeated_words and num_unique_words counting respectively the number of word repetitions and the number of unique words, as determined from the hash table built by add_word.


# let num_repeated_words () = 
   let i = ref 0 in 
   Hashtbl.iter (fun _ n  -> if !n>1 then incr i) table ;
   !i ;;
val num_repeated_words : unit -> int = <fun>

# let num_unique_words () = 
   let i = ref 0 in 
   Hashtbl.iter (fun _ _  -> incr i) table ;
   !i ;;
val num_unique_words : unit -> int = <fun>

Register the three previous functions so that they can be called from a C program.
```
# Callback.register "add word" add_word ;
 Callback.register "rep words" num_repeated_words ;
 Callback.register "uni words" num_unique_words ;
```

Rewrite the main function of the wc program so that it prints the number of unique words instead of the number of words. We must include the following header files:

#include <caml/mlvalues.h>
#include <caml/callback.h>

void read_file (char *path) {
  FILE *fd = fopen(path,"r") ;
  int chr=0 ;
  char buffer[80],*buff ;
  int num_chr=0, num_words, num_lines=0;

  if (fd == NULL) exit(2) ;
  buff=buffer; *buff=0;
  while ((chr=getc(fd))!=EOF) {
    num_chr++ ;
    if (chr=='\n') num_lines++ ;
    if (chr==' ' || chr=='\n' ||(buff-buffer)>=80) {
      if (buff!=buffer) { 
 *buff=0;
 buff=buffer;
 callback(*caml_named_value("add word"),copy_string(buffer));
      }
    }
    else *(buff++)=chr; 
  }
  num_words=Int_val(callback(*caml_named_value("uni words"),Val_unit)); 
  printf(" %d - %d - %d : %s\n",num_lines,num_words,num_chr,path);
}

Write the main function and the commands required to compile this program as an Objective CAML program.
```
int main (int argc,char **argv)
{
  caml_main(argv);
  if (argc>1) read_file(argv[1]);
  return 0;
}
```
Compiling to bytecode:
```
$ cc -c -I /usr/local/lib/ocaml/ wc.c
$ ocamlc -custom words.ml wc.o
```
Compiling to native code:
```
$ cc -c -I /usr/local/lib/ocaml/ wc.c
$ ocamlopt words.ml wc.o
```

Write the main function and the commands required to compile this program as a C program.

int main (int argc,char **argv)
{
  caml_startup(argv);
  if (argc>1) read_file(argv[1]);
  return 0;
}

Compiling to bytecode:

$ ocamlc -output-obj words.ml -o words.o
$ gcc -c -I /usr/local/lib/ocaml/ wc.c
$ gcc words.o wc.o -L /usr/local/lib/ocaml/ -lcamlrun -lcurses

Compiling to native code:

$ ocamlopt -output-obj words.ml -o wordsnat.o 
$ gcc -c -I /usr/local/lib/ocaml/ wc.c
$ gcc wordsnat.o wc.o -L /usr/local/lib/ocaml/ -lasmrun