Exercises

Exercises

Creation of a Toplevel and Standalone Executable

Consider again the Basic interpreter. Modify it to make a new toplevel.

Split the Basic application into 4 files, each with the extension .ml. The files will be organized like this: abstract syntax (syntax.ml), printing (pprint.ml), parsing (alexsynt.ml) and evaluation of instructions (eval.ml). The head of each file should contain the open statements to load the modules required for compilation. syntax.ml :


type op_unr = OPPOSE | NON  ;;

type op_bin = PLUS | MINUS | MULT | DIV | MOD  
            | EQUAL | INF | INFEQ | SUP | SUPEQ | DIFF 
            | AND | OR  ;;

type expression = 
    ExpInt of int 
  | ExpVar of string
  | ExpStr of string 
  | ExpUnr of op_unr * expression
  | ExpBin of expression * op_bin * expression  ;;

type instruction = 
    Rem of string
  | Goto of int 
  | Print of expression
  | Input of string 
  | If of expression * int 
  | Let of string * expression  ;;

type line = { num : int ; inst : instruction }  ;;

type program = line list  ;;

type phrase =  Line of line | List | Run | End  ;;

let priority_ou = function NON -> 1 | OPPOSE -> 7
let priority_ob = function 
    MULT | DIV  -> 6
  | PLUS | MINUS -> 5
  | MOD -> 4
  | EQUAL | INF | INFEQ | SUP | SUPEQ | DIFF -> 3
  | AND | OR -> 2 ;;

let pp_opbin = function  
    PLUS -> "+" | MULT -> "*" | MOD   -> "%" | MINUS -> "-" 
  | DIV -> "/"  | EQUAL -> " = " | INF -> " < " 
  | INFEQ -> " <= "   | SUP   -> " > " 
  | SUPEQ -> " >= "   | DIFF  -> " <> " | AND -> " & " | OR -> " | "  
let pp_opunr = function OPPOSE -> "-"  | NON -> "!"  ;;

pprint.ml :

open Syntax;;

let parenthesis x = "(" ^ x ^ ")";;

let pp_expression = 
 let rec ppg pr = function 
      ExpInt n -> (string_of_int n)
    | ExpVar v -> v 
    | ExpStr s -> "\"" ^ s ^ "\"" 
    | ExpUnr (op,e) -> 
        let res = (pp_opunr op)^(ppg (priority_ou op) e) 
        in if pr=0 then res else parenthesis res 
    | ExpBin (e1,op,e2) -> 
        let pr2 = priority_ob op
        in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2)
        (* parenthesis if the priority is not higher *)
        in if pr2 >= pr then res else parenthesis res
  and ppd pr exp = match exp with 

    (*  the sub-trees could only be different *)
    (*  in their binary operators             *) 
      ExpBin (e1,op,e2) -> 
        let pr2 = priority_ob op
        in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2)
        in if pr2 > pr then res else parenthesis res
    | _ -> ppg pr exp
  in ppg 0 ;;

let pp_instruction = function 
    Rem s     ->  "REM " ^ s
  | Goto n    ->  "GOTO " ^ (string_of_int n)
  | Print e   ->  "PRINT " ^ (pp_expression e)
  | Input v   ->  "INPUT " ^ v
  | If (e,n)  ->  "IF "^(pp_expression e)^" THEN "^(string_of_int n)
  | Let (v,e) ->  "LET " ^ v ^ " = " ^ (pp_expression e)  ;;

let pp_line l = (string_of_int l.num) ^ "  " ^ (pp_instruction l.inst)  ;;

alexsynt.ml :

open Syntax;;

type lexeme = Lint of int 
            | Lident of string 
            | Lsymbol of string  
            | Lstring of string
            | Lfin ;;

type str_lexer = {str:string; mutable position:int; size:int } ;;

let init_lex s = { str=s; position=0 ; size=String.length s } ;;

let advance cl = cl.position <- cl.position+1  ;;

let advance_n cl n = cl.position <- cl.position+n ;;

let extract pred cl = 
  let st = cl.str and ct = cl.position in
  let rec ext n = if n<cl.size && (pred st.[n]) then ext (n+1) else n in 
  let res = ext ct 
  in cl.position <- res ; String.sub cl.str ct (res-ct)  ;;

let extract_int = 
   let is_integer = function '0'..'9' -> true | _ -> false  
   in function cl -> int_of_string (extract is_integer cl)
let extract_ident =
   let is_alpha_num = function 
     'a'..'z' | 'A'..'Z' | '0' .. '9' | '_' -> true 
   | _ -> false  
   in extract is_alpha_num ;;

exception LexerError ;;

let  rec lexer cl = 
  let lexer_char c = match c with 
      ' ' 
    | '\t'     -> advance cl ; lexer cl 
    | 'a'..'z' 
    | 'A'..'Z' -> Lident (extract_ident cl)
    | '0'..'9' -> Lint (extract_int cl)
    | '"'      -> advance cl ; 
                  let res = Lstring (extract ((<>) '"') cl) 
                  in advance cl ; res 
    | '+' | '-' | '*' | '/' | '%' | '&' | '|' | '!' | '=' | '(' | ')'  -> 
                  advance cl; Lsymbol (String.make 1 c)
    | '<' 
    | '>'      -> advance cl; 
                  if cl.position >= cl.size then Lsymbol (String.make 1 c)
                  else  let cs = cl.str.[cl.position] 
                        in ( match (c,cs) with 
                               ('<','=') -> advance cl; Lsymbol "<=" 
                                   | ('>','=') -> advance cl; Lsymbol ">="
                             | ('<','>') -> advance cl; Lsymbol "<>"
                             |     _     -> Lsymbol (String.make 1 c) )
    | _ -> raise LexerError
  in 
     if cl.position >= cl.size then Lfin 
     else lexer_char cl.str.[cl.position] ;;

type exp_elem = 
    Texp of expression   (* expression         *)
  | Tbin of op_bin       (* binary operator    *)
  | Tunr of op_unr       (* unary operator     *)
  | Tpg                  (* right parenthesis  *) ;;

exception ParseError ;;

let symb_unr = function 
  "!" -> NON | "-" -> OPPOSE | _ -> raise ParseError 
let symb_bin = function
    "+" -> PLUS | "-" -> MINUS | "*" -> MULT | "/" -> DIV | "%" -> MOD 
  | "=" -> EQUAL | "<" -> INF | "<=" -> INFEQ | ">" -> SUP 
  | ">=" -> SUPEQ | "<>" -> DIFF | "&" -> AND | "|" -> OR 
  | _ -> raise ParseError 
let tsymb s = try Tbin (symb_bin s) with ParseError -> Tunr (symb_unr s) ;;

let reduce pr = function 
    (Texp e)::(Tunr op)::st  when  (priority_ou op) >= pr
       -> (Texp (ExpUnr (op,e)))::st
  | (Texp e1)::(Tbin op)::(Texp e2)::st  when  (priority_ob op) >= pr
       -> (Texp (ExpBin (e2,op,e1)))::st 
  | _ -> raise ParseError ;;

let rec pile_or_reduce lex stack = match lex , stack with 
    Lint n ,  _      ->  (Texp (ExpInt n))::stack 
  | Lident v ,  _    ->  (Texp (ExpVar v))::stack 
  | Lstring s , _    ->  (Texp (ExpStr s))::stack
  | Lsymbol "(" , _  ->  Tpg::stack
  | Lsymbol ")" , (Texp e)::Tpg::st  ->  (Texp e)::st
  | Lsymbol ")" , _ -> pile_or_reduce lex (reduce 0 stack) 
  | Lsymbol s , _ 
       -> let symbole = 
            if s<>"-" then tsymb s 
            (* resolve the ambiguity of the symbol ``-''   *)
            (* follow the stack (i.e last exp_elem pile)  *) 
            else match stack 
                 with (Texp _)::_  ->  Tbin MINUS 
                               | _ ->  Tunr OPPOSE 
          in ( match symbole with 
                 Tunr op  ->  (Tunr op)::stack 
               | Tbin op  -> 
                   ( try pile_or_reduce lex (reduce (priority_ob op) 
                                              stack )
                     with ParseError -> (Tbin op)::stack )
               | _ -> raise ParseError )
  | _ , _ -> raise ParseError ;;

let rec reduce_all = function 
  | [] -> raise ParseError
  | [Texp x] -> x 
  | st -> reduce_all (reduce 0 st) ;;

let parse_exp fin cl = 
  let p = ref 0 
  in let rec parse_un stack  = 
       let l = ( p:=cl.position ; lexer cl)
        in if not (fin l) then parse_un (pile_or_reduce l stack)
           else ( cl.position <- !p ; reduce_all stack )
  in parse_un []  ;;

let parse_inst cl = match lexer cl with 
    Lident s -> ( match s with 
        "REM" -> Rem (extract (fun _ -> true) cl)
      | "GOTO" -> Goto (match lexer cl with 
                          Lint p -> p 
                        | _ -> raise ParseError)
      | "INPUT" -> Input (match lexer cl with 
                            Lident v -> v 
                          | _ -> raise ParseError)
      | "PRINT" -> Print (parse_exp ((=) Lfin) cl)
      | "LET" -> 
          let l2 = lexer cl and l3 = lexer cl 
          in ( match l2 ,l3 with 
                   (Lident v,Lsymbol "=") -> Let (v,parse_exp ((=) Lfin) cl)
                 | _ -> raise ParseError )
      | "IF" -> 
          let test = parse_exp ((=) (Lident "THEN")) cl 
          in ( match ignore (lexer cl) ; lexer cl with 
                  Lint n  ->  If (test,n) 
                | _ -> raise ParseError )
      | _ -> raise ParseError ) 
  | _ -> raise ParseError  ;;

let parse str = 
  let cl = init_lex str 
  in match lexer cl with 
      Lint n -> Line { num=n ; inst=parse_inst cl }
    | Lident "LIST" -> List 
    | Lident "RUN" -> Run 
    | Lident "END" -> End 
    | _ -> raise ParseError  ;;

eval.ml :

open Syntax;;
open Pprint;;
open Alexsynt;;

type vl = Vint of int | Vstr of string | Vbool of bool  ;;

type environment = (string * vl) list ;;

type state = { line:int ; prog:program ; env:environment } ;;

exception RunError of int 
let runerr n = raise (RunError n) ;;

let rec eval_exp n envt expr = match expr with 
    ExpInt p  ->  Vint p
  | ExpVar v  -> ( try List.assoc v envt with Not_found -> runerr n )
  | ExpUnr (OPPOSE,e) ->  
      ( match eval_exp n envt e with 
          Vint p -> Vint (-p) 
        | _ -> runerr n )
  | ExpUnr (NON,e) ->  
      ( match eval_exp n envt e with 
          Vbool p -> Vbool (not p) 
        | _ -> runerr n )
  | ExpStr s -> Vstr s  
  | ExpBin (e1,op,e2) 
      -> match eval_exp n envt e1 , op , eval_exp n envt e2 with
              Vint v1 , PLUS  , Vint v2  ->  Vint (v1 + v2) 
            | Vint v1 , MINUS , Vint v2  ->  Vint (v1 - v2) 
            | Vint v1 , MULT  , Vint v2  ->  Vint (v1 * v2) 
            | Vint v1 ,  DIV  , Vint v2  when v2<>0 ->  Vint (v1 / v2) 
            | Vint v1 ,  MOD  , Vint v2  when v2<>0 ->  Vint (v1 mod v2) 

            | Vint v1 , EQUAL  , Vint v2  ->  Vbool (v1 = v2) 
            | Vint v1 , DIFF  , Vint v2  ->  Vbool (v1 <> v2) 
            | Vint v1 ,  INF  , Vint v2  ->  Vbool (v1 < v2) 
            | Vint v1 ,  SUP  , Vint v2  ->  Vbool (v1 > v2) 
            | Vint v1 , INFEQ , Vint v2  ->  Vbool (v1 <= v2) 
            | Vint v1 , SUPEQ , Vint v2  ->  Vbool (v1 >= v2) 

            | Vbool v1 , AND , Vbool v2  ->  Vbool (v1 && v2) 
            | Vbool v1 , OR , Vbool v2  ->  Vbool (v1 || v2) 

            | Vstr v1 , PLUS , Vstr v2 -> Vstr (v1 ^ v2) 
            | _ , _ , _  -> runerr n  ;;

let rec add v e env = match env with 
    [] -> [v,e]
  | (w,f)::l -> if w=v then (v,e)::l else (w,f)::(add v e l) ;;

let rec goto_line n prog = match prog with 
    [] -> runerr n
  | l::ll -> if l.num = n then prog
             else if l.num<n then goto_line n ll 
             else runerr n ;;

let print_vl v = match v with 
    Vint n -> print_int n
  | Vbool true -> print_string "true"
  | Vbool false -> print_string "false"
  | Vstr s -> print_string s ;;

let eval_inst state =
  let lc, ns =  
    match goto_line state.line state.prog with 
      [] -> failwith "empty program"
    | lc::[] -> lc,-1
    | lc::ls::_ -> lc,ls.num
  in 
    match lc.inst with 
      Rem _    ->  { state with line=ns }
    | Print e  ->  print_vl (eval_exp lc.num state.env e) ; 
                   print_newline () ;
                   { state with line=ns }
    | Let(v,e) ->  let ev = eval_exp lc.num state.env e 
                   in { state with line=ns; env=add v ev state.env }
    | Goto n   ->  { state with line=n }
    | Input v  ->  let x = try read_int () 
                           with Failure "int_of_string" -> 0
                   in { state with line=ns ; env=add v (Vint x) state.env }
    | If (t,n) ->  match eval_exp lc.num state.env t with 
                     Vbool true  -> { state with line=n }
                   | Vbool false -> { state with line=ns }
                   | _ -> runerr n  ;;

let rec run state = 
 if state.line = -1 then state else run (eval_inst state) ;;

let rec insert line p = match p with  
    [] -> [line]
  | l::prog -> 
      if l.num < line.num then l::(insert line prog)
      else if l.num=line.num then line::prog
      else line::l::prog ;;

let print_prog state = 
  let print_line x = print_string (pp_line x) ; print_newline () 
  in print_newline () ;
     List.iter print_line state.prog ;
     print_newline () ;;

let premiere_line = function [] -> 0 | i::_ -> i.num  ;;

exception Fin
let one_command state =
  print_string "> " ; flush stdout ;
  try 
    match parse (input_line stdin) with 
       Line l -> { state with prog=insert l state.prog }
     | List  -> (print_prog state ; state )
     | Run -> run {state with line = premiere_line state.prog}
     | End -> raise Fin
  with 
      LexerError -> print_string "Illegal character\n"; state 
    | ParseError -> print_string "syntax error\n"; state 
    | RunError n -> 
        print_string "runtime error at line ";
        print_int n ;
        print_string "\n";  
        state ;;

let go () = 
try 
  print_string "Mini-BASIC version 0.1\n\n";
  let rec loop state = loop (one_command state)  in 
    loop { line=0; prog=[]; env=[] }
with Fin -> print_string "A bientôt...\n";;

Compile all files separately.
```
$ ocamlc -c syntax.ml 
$ ocamlc -c pprint.ml
$ ocamlc -c alexsynt.ml
$ ocamlc -c eval.ml
```
Add a file mainbasic.ml which contains only the statement for calling the main function.
mainbasic.ml :
```
open Eval;;

go ();;
```

Create a new toplevel with the name topbasic, which starts the Basic interpreter. création du toplevel :

$ ocamlmktop -o topbasic syntax.cmo pprint.cmo alexsynt.cmo eval.cmo mainbasic.ml

test du toplevel :

$ topbasic
Mini-BASIC version 0.1

> 10 PRINT "DONNER UN NOMBRE"
> 20 INPUT X
> 30 PRINT X
> LIST

10  PRINT "DONNER UN NOMBRE"
20  INPUT X
30  PRINT X

> RUN
DONNER UN NOMBRE
44
44
> END
A bientôt...
        Objective Caml version 2.04

#

Create a standalone executable which runs the Basic interpreter.
compilation et édition de liens :
```
$ ocamlc -custom -o basic.exe syntax.cmo pprint.cmo alexsynt.cmo eval.cmo mainbasic.ml
```
test de l'exécutable autonome :
```
$ basic.exe
Mini-BASIC version 0.1

> 10 PRINT "BONJOUR"
> LIST

10  PRINT "BONJOUR"

> RUN
BONJOUR
> END
A bientôt...
$
```

Comparison of Performance

Try to compare the performance of code produced by the bytecode compiler and by the native compiler. For this purpose, write an application for sorting lists and arrays.

Write a polymorphic function for sorting lists. The order relation should be passed as an argument to the sort function. The sort algorithm can be selected by the reader. For example: bubble sort, or quick sort. Write this function as sort.ml. On utilise les fichiers sort.mli et sort.ml de la distribution qui définissent les fonctions list et array de tri d'une liste et d'un tableau.

sort.mli :

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id: sort.mli,v 1.1.1.1 2000/06/26 14:37:50 xleroy Exp $ *)

(* Module [Sort]: sorting and merging lists *)

val list : ('a -> 'a -> bool) -> 'a list -> 'a list
        (* Sort a list in increasing order according to an ordering predicate.
           The predicate should return [true] if its first argument is
           less than or equal to its second argument. *)

val array : ('a -> 'a -> bool) -> 'a array -> unit
        (* Sort an array in increasing order according to an
           ordering predicate.
           The predicate should return [true] if its first argument is
           less than or equal to its second argument.
           The array is sorted in place. *)

val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
        (* Merge two lists according to the given predicate.
           Assuming the two argument lists are sorted according to the
           predicate, [merge] returns a sorted list containing the elements
           from the two lists. The behavior is undefined if the two
           argument lists were not sorted. *)

sort.ml

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id: sort.ml,v 1.1.1.1 2000/06/26 14:37:50 xleroy Exp $ *)

(* Merging and sorting *)

open Array

let rec merge order l1 l2 =
  match l1 with
    [] -> l2
  | h1 :: t1 ->
      match l2 with
        [] -> l1
      | h2 :: t2 ->
          if order h1 h2
          then h1 :: merge order t1 l2
          else h2 :: merge order l1 t2

let list order l =
  let rec initlist = function
      [] -> []
    | [e] -> [[e]]
    | e1::e2::rest ->
        (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in
  let rec merge2 = function
      l1::l2::rest -> merge order l1 l2 :: merge2 rest
    | x -> x in
  let rec mergeall = function
      [] -> []
    | [l] -> l
    | llist -> mergeall (merge2 llist) in
  mergeall(initlist l)

let swap arr i j =
  let tmp = unsafe_get arr i in
  unsafe_set arr i (unsafe_get arr j);
  unsafe_set arr j tmp

let array order arr =
  let rec qsort lo hi =
    if hi <= lo then ()
    else if hi - lo < 5 then begin
      (* Use insertion sort *)
      for i = lo + 1 to hi do
        let val_i = unsafe_get arr i in
        if order val_i (unsafe_get arr (i - 1)) then begin
          unsafe_set arr i (unsafe_get arr (i - 1));
          let j = ref (i - 1) in
          while !j >= 1 && order val_i (unsafe_get arr (!j - 1)) do
            unsafe_set arr !j (unsafe_get arr (!j - 1));
            decr j
          done;
          unsafe_set arr !j val_i
        end
      done
    end else begin
      let mid = (lo + hi) lsr 1 in
      (* Select median value from among LO, MID, and HI *)
      let pivotpos =
        let vlo = unsafe_get arr lo
        and vhi = unsafe_get arr hi
        and vmid = unsafe_get arr mid in
        if order vlo vmid then
          if order vmid vhi then mid
          else if order vlo vhi then hi else lo
        else
          if order vhi vmid then mid
          else if order vhi vlo then hi else lo in
      swap arr pivotpos hi;
      let pivot = unsafe_get arr hi in
      let i = ref lo and j = ref hi in
      while !i < !j do
        while !i < hi && order (unsafe_get arr !i) pivot do incr i done;
        while !j > lo && order pivot (unsafe_get arr !j) do decr j done;
        if !i < !j then swap arr !i !j
      done;
      swap arr !i hi;
      (* Recurse on larger half first *)
      if (!i - 1) - lo >= hi - (!i + 1) then begin
        qsort lo (!i - 1); qsort (!i + 1) hi
      end else begin
        qsort (!i + 1) hi; qsort lo (!i - 1)
      end
    end in
  qsort 0 (Array.length arr - 1)

Create the main function in the file trilist.ml, which uses the previous function and applies it to a list of integers by sorting it in increasing order, then in decreasing order. interval.ml :

let interval order next a b = 
  let rec aux a = 
    if not (order a b) then [a] else  a :: aux  (next a) 
  in aux a;;

trilist.ml :


let main () = 
  let il = Interval.interval (>) (fun x -> x -1) 50000 20 
  and il2 = Interval.interval (<) (fun x -> x + 1) 20 50000  in  
    Sort.list (<) il, Sort.list (>) il2;;

main();;

Create two standalone executables - one with the bytecode compiler, and another with the native compiler. Measure the execution time of these two programs. Choose lists of sufficient size to get a good idea of the time differences.
1. code-octet (Unix) : trilbyte.exe
```
ocamlc -custom -o trilbyte.exe sort.mli sort.ml interval.ml trilist.ml
```
2. natif (Unix) : trilopt.exe
```
ocamlopt -o trilopt.exe sort.mli sort.ml interval.ml trilist.ml
```
Performances :

trilbyte.exe trilopt.exe

2,55 secondes (user) 1,67 secondes (user)

Le rapport trilopt.exe / trilbyte.exe est de 2/3.
Rewrite the sort program for arrays. Continue using an order function as argument. Perform the test on arrays filled in the same manner as for the lists.
triarray.ml :
```
let main () = 
  let il = Array.of_list(Interval.interval (>) (fun x -> x -1) 50000 20) 
  and il2 = Array.of_list(Interval.interval (<) (fun x -> x + 1) 20 50000)  in  
    Sort.array (<) il, Sort.array (>) il2;;

main();;
```
1. code-octet (Unix) : triabyte.exe
```
ocamlc -custom -o triabyte.exe sort.mli sort.ml interval.ml triarray.ml
```
2. natif (Unix) : triaopt.exe
```
ocamlopt -o triaoptu.exe sort.mli sort.ml interval.ml triarray.ml
```
Performances :

triabyte.exe triaopt.exe

515 s 106 s

Le rapport triaopt.exe / triabyte.exe est de 1/5.
What can we say about the results of these tests? Le compilateur natif apporte un gain de temps d'exécution variable ( facteur 2/3 pour les liste et 1/5 pour les tableaux).

trilbyte.exe	trilopt.exe
2,55 secondes (user)	1,67 secondes (user)

triabyte.exe	triaopt.exe
515 s	106 s