Précédent Index Suivant

Exercices

Création de toplevels et d'exécutables autonomes

On reprend l'interprète de Basic pour créer une nouvelle boucle d'interaction.
  1. Découper l'application Basic en 4 fichiers d'extension .ml contenant respectivement : la syntaxe abstraite (syntax.ml), l'afficheur (pprint.ml), l'analyse syntaxique (alexsynt.ml) et l'évaluation des instructions (eval.ml). Chaque début de fichier contiendra l'ouverture des modules nécessaires à sa compilation. syntax.ml :

    type op_unr = OPPOSE | NON ;;

    type op_bin = PLUS | MOINS | MULT | DIV | MOD
    | EGAL | INF | INFEQ | SUP | SUPEQ | DIFF
    | ET | OU ;;

    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 ligne = { num : int ; inst : instruction } ;;

    type program = ligne list ;;

    type phrase = Ligne of ligne | List | Run | End ;;

    let priority_ou = function NON -> 1 | OPPOSE -> 7
    let priority_ob = function
    MULT | DIV -> 6
    | PLUS | MOINS -> 5
    | MOD -> 4
    | EGAL | INF | INFEQ | SUP | SUPEQ | DIFF -> 3
    | ET | OU -> 2 ;;

    let pp_opbin = function
    PLUS -> "+" | MULT -> "*" | MOD -> "%" | MOINS -> "-"
    | DIV -> "/" | EGAL -> " = " | INF -> " < "
    | INFEQ -> " <= " | SUP -> " > "
    | SUPEQ -> " >= " | DIFF -> " <> " | ET -> " & " | OU -> " | "
    let pp_opunr = function OPPOSE -> "-" | NON -> "!" ;;
    pprint.ml :
    open Syntax;;

    let parenthese 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 parenthese res
    | ExpBin (e1,op,e2) ->
    let pr2 = priority_ob op
    in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2)
    (* parenthèse si la priorite n'est pas supérieure *)
    in if pr2 >= pr then res else parenthese res
    and ppd pr exp = match exp with
    (* les sous-arbres droits ne diffèrent *)
    (* que pour les opérateurs binaires *)
    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 parenthese 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_ligne 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 chaine_lexer = {chaine:string; mutable courant:int; taille:int } ;;

    let init_lex s = { chaine=s; courant=0 ; taille=String.length s } ;;

    let avance cl = cl.courant <- cl.courant+1 ;;

    let avance_n cl n = cl.courant <- cl.courant+n ;;

    let extrait pred cl =
    let st = cl.chaine and ct = cl.courant in
    let rec ext n = if n<cl.taille && (pred st.[n]) then ext (n+1) else n in
    let res = ext ct
    in cl.courant <- res ; String.sub cl.chaine ct (res-ct) ;;

    let extrait_int =
    let est_entier = function '0'..'9' -> true | _ -> false
    in function cl -> int_of_string (extrait est_entier cl)
    let extrait_ident =
    let est_alpha_num = function
    'a'..'z' | 'A'..'Z' | '0' .. '9' | '_' -> true
    | _ -> false
    in extrait est_alpha_num ;;

    exception LexerErreur ;;

    let rec lexer cl =
    let lexer_char c = match c with
    ' '
    | '\t' -> avance cl ; lexer cl
    | 'a'..'z'
    | 'A'..'Z' -> Lident (extrait_ident cl)
    | '0'..'9' -> Lint (extrait_int cl)
    | '"' -> avance cl ;
    let res = Lstring (extrait ((<>) '"') cl)
    in avance cl ; res
    | '+' | '-' | '*' | '/' | '%' | '&' | '|' | '!' | '=' | '(' | ')' ->
    avance cl; Lsymbol (String.make 1 c)
    | '<'
    | '>' -> avance cl;
    if cl.courant >= cl.taille then Lsymbol (String.make 1 c)
    else let cs = cl.chaine.[cl.courant]
    in ( match (c,cs) with
    ('<','=') -> avance cl; Lsymbol "<="
    | ('>','=') -> avance cl; Lsymbol ">="
    | ('<','>') -> avance cl; Lsymbol "<>"
    | _ -> Lsymbol (String.make 1 c) )
    | _ -> raise LexerErreur
    in
    if cl.courant >= cl.taille then Lfin
    else lexer_char cl.chaine.[cl.courant] ;;

    type exp_elem =
    Texp of expression (* expression *)
    | Tbin of op_bin (* opérateur binaire *)
    | Tunr of op_unr (* opérateur unaire *)
    | Tpg (* parenthèse gauche *) ;;

    exception ParseErreur ;;

    let symb_unr = function
    "!" -> NON | "-" -> OPPOSE | _ -> raise ParseErreur
    let symb_bin = function
    "+" -> PLUS | "-" -> MOINS | "*" -> MULT | "/" -> DIV | "%" -> MOD
    | "=" -> EGAL | "<" -> INF | "<=" -> INFEQ | ">" -> SUP
    | ">=" -> SUPEQ | "<>" -> DIFF | "&" -> ET | "|" -> OU
    | _ -> raise ParseErreur
    let tsymb s = try Tbin (symb_bin s) with ParseErreur -> Tunr (symb_unr s) ;;

    let reduit 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 ParseErreur ;;

    let rec empile_ou_reduit 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 ")" , _ -> empile_ou_reduit lex (reduit 0 stack)
    | Lsymbol s , _
    -> let symbole =
    if s<>"-" then tsymb s
    (* lever l'ambiguïte du symbole ``-'' *)
    (* suivant la pile (i.e dernier exp_elem empile) *)
    else match stack
    with (Texp _)::_ -> Tbin MOINS
    | _ -> Tunr OPPOSE
    in ( match symbole with
    Tunr op -> (Tunr op)::stack
    | Tbin op ->
    ( try empile_ou_reduit lex (reduit (priority_ob op)
    stack )
    with ParseErreur -> (Tbin op)::stack )
    | _ -> raise ParseErreur )
    | _ , _ -> raise ParseErreur ;;

    let rec reduit_tout = function
    | [] -> raise ParseErreur
    | [Texp x] -> x
    | st -> reduit_tout (reduit 0 st) ;;

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

    let parse_inst cl = match lexer cl with
    Lident s -> ( match s with
    "REM" -> Rem (extrait (fun _ -> true) cl)
    | "GOTO" -> Goto (match lexer cl with
    Lint p -> p
    | _ -> raise ParseErreur)
    | "INPUT" -> Input (match lexer cl with
    Lident v -> v
    | _ -> raise ParseErreur)
    | "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 ParseErreur )
    | "IF" ->
    let test = parse_exp ((=) (Lident "THEN")) cl
    in ( match ignore (lexer cl) ; lexer cl with
    Lint n -> If (test,n)
    | _ -> raise ParseErreur )
    | _ -> raise ParseErreur )
    | _ -> raise ParseErreur ;;

    let parse str =
    let cl = init_lex str
    in match lexer cl with
    Lint n -> Ligne { num=n ; inst=parse_inst cl }
    | Lident "LIST" -> List
    | Lident "RUN" -> Run
    | Lident "END" -> End
    | _ -> raise ParseErreur ;;
    eval.ml :
    open Syntax;;
    open Pprint;;
    open Alexsynt;;

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

    type environnement = (string * valeur) list ;;

    type etat = { ligne:int ; prog:program ; env:environnement } ;;

    exception RunErreur of int
    let runerr n = raise (RunErreur 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 , MOINS , 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 , EGAL , 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 , ET , Vbool v2 -> Vbool (v1 && v2)
    | Vbool v1 , OU , Vbool v2 -> Vbool (v1 || v2)

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

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

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

    let print_valeur 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 etat =
    let lc, ns =
    match goto_ligne etat.ligne etat.prog with
    [] -> failwith "programme vide"
    | lc::[] -> lc,-1
    | lc::ls::_ -> lc,ls.num
    in
    match lc.inst with
    Rem _ -> { etat with ligne=ns }
    | Print e -> print_valeur (eval_exp lc.num etat.env e) ;
    print_newline () ;
    { etat with ligne=ns }
    | Let(v,e) -> let ev = eval_exp lc.num etat.env e
    in { etat with ligne=ns; env=ajoute v ev etat.env }
    | Goto n -> { etat with ligne=n }
    | Input v -> let x = try read_int ()
    with Failure "int_of_string" -> 0
    in { etat with ligne=ns ; env=ajoute v (Vint x) etat.env }
    | If (t,n) -> match eval_exp lc.num etat.env t with
    Vbool true -> { etat with ligne=n }
    | Vbool false -> { etat with ligne=ns }
    | _ -> runerr n ;;

    let rec run etat =
    if etat.ligne = -1 then etat else run (eval_inst etat) ;;

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

    let print_prog etat =
    let print_ligne x = print_string (pp_ligne x) ; print_newline ()
    in print_newline () ;
    List.iter print_ligne etat.prog ;
    print_newline () ;;

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

    exception Fin
    let une_commande etat =
    print_string "> " ; flush stdout ;
    try
    match parse (input_line stdin) with
    Ligne l -> { etat with prog=inserer l etat.prog }
    | List -> (print_prog etat ; etat )
    | Run -> run {etat with ligne = premiere_ligne etat.prog}
    | End -> raise Fin
    with
    LexerErreur -> print_string "Illegal character\n"; etat
    | ParseErreur -> print_string "syntax error\n"; etat
    | RunErreur n ->
    print_string "runtime error at line ";
    print_int n ;
    print_string "\n";
    etat ;;

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





  2. Compiler séparément chacun des fichiers.
    $ ocamlc -c syntax.ml 
    $ ocamlc -c pprint.ml
    $ ocamlc -c alexsynt.ml
    $ ocamlc -c eval.ml
    


  3. Rajouter un fichier mainbasic.ml qui ne contiendra que le lancement de la fonction principale. mainbasic.ml :
    open Eval;;

    go ();;


  4. Créer un nouveau toplevel, de nom topbasic, qui démarre l'interprète Basic. 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
    
    # 
    


  5. Créer un exécutable autonome lançant l'interprète Basic. 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...
    $
    

Comparaison de performances

On cherche à comparer les performances du code produit par le compilateur de byte-code et par le compilateur natif. Pour cela on écrira une application de tri sur des listes et des tableaux.
  1. Écrire une fonction polymorphe de tri sur les listes, la relation d'ordre sera passée comme paramètre de la fonction de tri. L'algorithme de tri est laissé au choix du lecteur. On peut imaginer soit un tri à bulle, soit un tri rapide. On écrira cette fonction dans le fichier 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 2000/01/21 09:40:00 emmanuel 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 2000/01/21 09:18:40 emmanuel 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)


  2. Écrire un programme principal, dans le fichier trilist.ml, qui utilise la fonction précédente et l'applique sur une liste d'entiers en la triant en ordre croissant puis en ordre décroissant. 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();;


  3. Créer deux exécutables autonomes, un avec le compilateur de byte-code et l'autre en natif. Mesurer les temps d'exécution de ces deux programmes. On choisira des listes de tailles suffisamment importantes pour les mesures de temps.
    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.


  4. Réécrire le tri pour des tableaux, en utilisant toujours une fonction d'ordre en paramètre. Effectuer les mesures sur des tableaux remplis de la même manière que les listes précédentes. 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.


  5. Que peut-on dire des résultats des mesures? Le compilateur natif apporte un gain de temps d'exécution variable ( facteur 2/3 pour les liste et 1/5 pour les tableaux).

Précédent Index Suivant