Source file metrics_cabs.ml

(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2023                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

(** Implementation of cyclomatic complexity measures on CAbs' AST *)
open Cabs
open Metrics_base
open Metrics_base.BasicMetrics

class metricsCabsVisitor = object(self)
  inherit Cabsvisit.nopCabsVisitor

  (* Global metrics store for this Cabs AST *)
  val global_metrics = ref empty_metrics
  (* Local metrics in computation *)
  val local_metrics = ref empty_metrics

  (* Was last statement a case ? *)
  val was_case = ref false

  (* Local metrics are kept stored after computation in this map of maps.
     Its storing hierarchy is as follows: filename -> function_name -> metrics *)
  val mutable metrics_map:
    (BasicMetrics.t Metrics_base.OptionKf.Map.t) Datatype.Filepath.Map.t =
    Datatype.Filepath.Map.empty

  val functions_no_source: (string, int) Hashtbl.t = Hashtbl.create 97
  val functions_with_source: (string, int) Hashtbl.t = Hashtbl.create 97
  val mutable standalone = true

  (* Getters/setters *)
  method functions_no_source = functions_no_source
  method functions_with_source = functions_with_source
  method set_standalone v = standalone <- v
  method get_metrics = !global_metrics
  method private update_metrics_map filename strmap =
    metrics_map <- Datatype.Filepath.Map.add filename strmap metrics_map

  (* Utility methods to increase metrics counts *)
  method private incr_both_metrics f =
    apply_then_set f global_metrics;
    apply_then_set f local_metrics

  method add_to_functions_with_source (funcname:string) =
    Hashtbl.add functions_with_source funcname 0;
    Hashtbl.remove functions_no_source funcname;

  method private record_and_clear metrics =
    let filename = metrics.cfile_name
    and func = metrics.cfunc in
    local_metrics := BasicMetrics.set_cyclo !local_metrics
        (BasicMetrics.compute_cyclo !local_metrics);
    global_metrics := BasicMetrics.set_cyclo !global_metrics
        (!global_metrics.ccyclo + !local_metrics.ccyclo);
    (try
       let fun_tbl = Datatype.Filepath.Map.find filename metrics_map in
       self#update_metrics_map filename
         (Metrics_base.OptionKf.Map.add func !local_metrics fun_tbl);
     with
     | Not_found ->
       let new_stringmap =
         Metrics_base.OptionKf.Map.add func !local_metrics
           Metrics_base.OptionKf.Map.empty
       in
       self#update_metrics_map filename new_stringmap;
    );
    local_metrics := empty_metrics;

  method! vdef def =
    match def with
    | FUNDEF (_, sname, _, _, _) ->
      begin
        let funcname = Metrics_base.extract_fundef_name sname in
        local_metrics :=
          {!local_metrics with
           cfile_name = get_filename def;
           cfunc = Some (Metrics_base.kf_of_cabs_name sname);
           cfuncs = 1; (* Only one function is indeed being defined here *)};
        Metrics_parameters.debug
          ~level:1 "Definition of function %s encountered@." funcname;
        apply_then_set incr_funcs global_metrics;
        self#add_to_functions_with_source funcname;
        (* On return record the analysis of the function. *)
        Cil.ChangeDoChildrenPost
          ([def],
           fun _ ->
             begin
               if !local_metrics <> empty_metrics
               then self#record_and_clear !local_metrics;
               [def]
             end
          );
      end
    | DECDEF _
    | TYPEDEF _
    | ONLYTYPEDEF _
    | GLOBASM _
    | PRAGMA _
    | STATIC_ASSERT _
    | LINKAGE _
    | GLOBANNOT _ -> Cil.DoChildren;

  method! vexpr expr =
    (match expr.expr_node with
     | NOTHING -> ()
     | UNARY (unop, _) ->
       begin
         match unop with
         | PREINCR
         | POSINCR
         | PREDECR
         | POSDECR -> self#incr_both_metrics incr_assigns
         | MINUS
         | PLUS
         | NOT
         | BNOT -> ()
         | MEMOF -> self#incr_both_metrics incr_ptrs
         | ADDROF -> ()
       end
     | LABELADDR _ -> ()
     | BINARY (bop, _, _) ->
       begin
         match bop with
         | ADD | SUB | MUL | DIV | MOD
         | BAND | BOR | XOR
         | SHL | SHR | EQ | NE | LT
         | GT | LE | GE -> ()
         | AND | OR -> self#incr_both_metrics incr_dpoints
         | ASSIGN
         | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN
         | DIV_ASSIGN | BOR_ASSIGN | XOR_ASSIGN
         | SHL_ASSIGN | SHR_ASSIGN | BAND_ASSIGN
         | MOD_ASSIGN ->
           self#incr_both_metrics incr_assigns;
       end
     | CAST _ -> ()
     | CALL  _ -> self#incr_both_metrics incr_calls;
     | QUESTION _ ->
       self#incr_both_metrics incr_dpoints;
       self#incr_both_metrics incr_ifs;
     | COMMA _
     | CONSTANT _
     | PAREN _
     | VARIABLE _
     | EXPR_SIZEOF _
     | TYPE_SIZEOF _
     | EXPR_ALIGNOF _
     | TYPE_ALIGNOF _
     | INDEX _
     | MEMBEROF _
     | MEMBEROFPTR _
     | GNU_BODY _
     | EXPR_PATTERN _
     | GENERIC _ -> ());
    Cil.DoChildren

  (* Allows to count only one control-flow branch per case lists *)
  method private set_case stmt =
    match stmt.stmt_node with
    | CASERANGE _ | CASE _ -> was_case := true;
    | DEFAULT _
    | _ -> was_case := false

  method! vstmt stmt =
    self#incr_both_metrics incr_slocs;
    (match stmt.stmt_node with
     | DEFAULT _ -> () (* The default case is not counted as a path choice
                          point *)
     | CASERANGE _
     | CASE _ ->
       if not !was_case then self#incr_both_metrics incr_dpoints;
     | IF _ ->
       self#incr_both_metrics incr_ifs;
       self#incr_both_metrics incr_dpoints;
     | NOP _
     | COMPUTATION _
     | BLOCK _ -> ()
     (* Next 3 are all loop instructions *)
     | WHILE _
     | DOWHILE _
     | FOR _ ->
       self#incr_both_metrics incr_loops;
       self#incr_both_metrics incr_dpoints;
     | BREAK _
     | CONTINUE _ -> ()
     | RETURN _ | THROW _ -> self#incr_both_metrics incr_exits;
     | SWITCH _ -> ()
     | LABEL _ -> ()
     | GOTO _
     | COMPGOTO _ -> self#incr_both_metrics incr_gotos;
     | DEFINITION _
     | ASM _
     | SEQUENCE _
     | TRY_EXCEPT _
     | TRY_FINALLY _
     | TRY_CATCH _
     | CODE_ANNOT _
     | CODE_SPEC _ -> ());
    self#set_case stmt;
    Cil.DoChildren

  method private stats_of_filename filename =
    try Datatype.Filepath.Map.find filename metrics_map
    with
    | Not_found ->
      Metrics_parameters.fatal "Metrics for file %a not_found@."
        Datatype.Filepath.pretty filename

  method pp_file_metrics fmt filename =
    Format.fprintf fmt "@[<v 0>%a@]"
      (fun fmt filename ->
         let fun_tbl = self#stats_of_filename filename in
         OptionKf.Map.iter (fun _fun_name fmetrics ->
             Format.fprintf fmt "@ %a" pp_base_metrics fmetrics)
           fun_tbl;
      ) filename

  method pp_detailed_text_metrics fmt () =
    Datatype.Filepath.Map.iter
      (fun filename _func_tbl ->
         Format.fprintf fmt "%a" self#pp_file_metrics filename) metrics_map

end
;;


(** Halstead metrics computation *)
module Halstead = struct
  (* We follow http://www.verifysoft.com/en_halstead_metrics.html
     for the classification of operands and operators
     operands = ids, typenames, typespecs, constants
  *)

  let update_val value key tbl =
    try
      let v = Hashtbl.find tbl key in
      Hashtbl.replace tbl key (v + value);
    with
    | Not_found -> Hashtbl.add tbl key value
  ;;

  let update_val_incr key tbl = update_val 1 key tbl;;

  type operand_tbl = {
    var_tbl : (string, int) Hashtbl.t;
    cst_tbl : (Cabs.constant, int) Hashtbl.t;
  }
  ;;

  type operator_tbl = {
    knownop_tbl : (string, int) Hashtbl.t;
    otherop_tbl  : (string, int) Hashtbl.t;
    reserved_tbl : (string, int) Hashtbl.t;
    tspec_tbl : (Cabs.typeSpecifier, int) Hashtbl.t;
  }
  ;;

  let id_from_init iname =
    match (fst iname) with
    | s, _, _, _ -> s
  ;;

  class halsteadCabsVisitor = object(self)

    inherit Cabsvisit.nopCabsVisitor

    val operand_tbl = {
      var_tbl = Hashtbl.create 7;
      cst_tbl = Hashtbl.create 7;
    }

    val operator_tbl = {
      knownop_tbl = Hashtbl.create 7;
      otherop_tbl = Hashtbl.create 7;
      reserved_tbl = Hashtbl.create 7;
      tspec_tbl = Hashtbl.create 7;
    }

    method get_operator_tbl () = operator_tbl
    method get_operand_tbl () = operand_tbl

    method add_paren () =
      update_val_incr "(" operator_tbl.otherop_tbl;
      update_val_incr ")" operator_tbl.otherop_tbl;

    method! vexpr e =
      match e.Cabs.expr_node with
      | UNARY _ ->
        let unop = fst (Cprint.get_operator e) in
        update_val_incr unop operator_tbl.knownop_tbl;
        Cil.DoChildren;
      | BINARY _ ->
        let binop = fst (Cprint.get_operator e) in
        update_val_incr binop operator_tbl.knownop_tbl;
        Cil.DoChildren;
      | QUESTION _ ->
        update_val_incr "?" operator_tbl.otherop_tbl;
        update_val_incr ":" operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | COMMA elist ->
        let n = List.length elist in
        if (n > 1) then
          update_val (n - 1) "," operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | CONSTANT c ->
        update_val_incr c operand_tbl.cst_tbl;
        Cil.DoChildren;
      | PAREN _ ->
        self#add_paren ();
        Cil.DoChildren;
      | VARIABLE s ->
        update_val_incr s operand_tbl.var_tbl;
        Cil.DoChildren;
      | EXPR_SIZEOF _ ->
        update_val_incr "sizeof" operator_tbl.reserved_tbl;
        Cil.DoChildren;
      | TYPE_SIZEOF _ ->
        update_val_incr "sizeof" operator_tbl.reserved_tbl;
        Cil.DoChildren;
      | INDEX _ ->
        update_val_incr "[]" operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | _ -> Cil.DoChildren;


    method! vstmt s =
      let reserved rstr =
        update_val_incr rstr operator_tbl.reserved_tbl;
        Cil.DoChildren;
      in
      match s.Cabs.stmt_node with
      | BLOCK _ ->
        update_val_incr "{" operator_tbl.otherop_tbl;
        update_val_incr "}" operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | SEQUENCE _ ->
        print_string "seq\n";
        update_val_incr ";" operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | IF _ -> self#add_paren (); reserved "if";
      | WHILE _ -> self#add_paren (); reserved "while";
      | DOWHILE _ ->
        update_val_incr "do" operator_tbl.reserved_tbl;
        self#add_paren ();
        reserved "while";
      | FOR _ ->
        self#add_paren ();
        update_val 2 ";" operator_tbl.otherop_tbl;
        reserved "for";
      | BREAK _ -> reserved "break";
      | CONTINUE _ -> reserved "continue";
      | RETURN _ -> reserved "return";
      | SWITCH _ -> self#add_paren (); reserved "switch";
      | CASE _ -> reserved "case";
      | CASERANGE _ ->
        update_val_incr "..." operator_tbl.otherop_tbl;
        update_val 2 ";" operator_tbl.otherop_tbl;
        reserved "case";
      | DEFAULT _ -> reserved "default";
      | LABEL _ ->
        update_val_incr ":" operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | GOTO (s, _) ->
        let lname = Format.sprintf "label_%s" s in
        update_val_incr lname operand_tbl.var_tbl;
        reserved "goto";

      | COMPGOTO _ ->
        update_val_incr "*" operator_tbl.otherop_tbl;
        reserved "goto";

      | DEFINITION _ -> Cil.DoChildren;
      | ASM _ -> reserved "asm";
      | TRY_EXCEPT _ ->
        update_val_incr "except" operator_tbl.reserved_tbl;
        reserved "try";
      | TRY_FINALLY _ ->
        update_val_incr "finally" operator_tbl.reserved_tbl;
        reserved "try";
      | _ -> Cil.DoChildren;

    method! vtypespec tspec =
      update_val_incr tspec operator_tbl.tspec_tbl;
      Cil.DoChildren;

    method! vspec spec =
      let reserved rstr =
        update_val_incr rstr operator_tbl.reserved_tbl;
      in
      let do_spec s =
        match s with
        | SpecTypedef -> reserved "typedef"
        | SpecInline -> reserved "inline"
        | SpecStorage AUTO -> reserved "auto"
        | SpecStorage STATIC -> reserved "static"
        | SpecStorage EXTERN -> reserved "extern"
        | SpecStorage REGISTER -> reserved "register"
        | SpecCV CV_CONST -> reserved "const"
        | SpecCV CV_VOLATILE -> reserved "volatile"
        | SpecCV CV_RESTRICT -> reserved "restrict"
        | _ -> ()
      in List.iter do_spec spec; Cil.DoChildren;

    method! vdecltype tdecl =
      match tdecl with
      | JUSTBASE ->
        Cil.SkipChildren;
      | PARENTYPE _  ->
        self#add_paren ();
        Cil.DoChildren;
      | ARRAY _ ->
        update_val_incr "array" operator_tbl.reserved_tbl;
        Cil.DoChildren;
      | PTR _ ->
        update_val_incr "*" operator_tbl.otherop_tbl;
        Cil.DoChildren;
      | PROTO _ ->
        Cil.SkipChildren;


    method! vinitexpr ie =
      ( match ie with
        | COMPOUND_INIT l ->
          let n = List.length l in
          if n > 0 then
            update_val n "," operator_tbl.otherop_tbl;
        | _ -> ());
      Cil.DoChildren

    method! vblock b =
      if b.bstmts <> [] then (
        let n = List.length b.bstmts in
        update_val n ";" operator_tbl.otherop_tbl);
      if b.battrs <> [] then
        update_val (List.length b.battrs) "," operator_tbl.otherop_tbl;
      Cil.DoChildren;

    method! vdef d =
      match d with
      | FUNDEF (bl, (_, (fname, dtype, _, nloc)), b, loc1, loc2) ->
        Cil.ChangeDoChildrenPost(
          [FUNDEF(bl, ([], (fname, dtype, [], nloc)), b, loc1, loc2)],
          fun x -> x)

      | DECDEF (_, (_, name_list), _) ->
        let n =
          List.fold_left
            (fun acc n ->
               update_val_incr (id_from_init n) operand_tbl.var_tbl;
               acc + 1 )
            (-1) name_list in
        begin
          assert(n >= 0);
          if (n > 0) then update_val n "," operator_tbl.otherop_tbl;
          Cil.DoChildren;
        end

      | _ -> Cil.DoChildren

  end
  ;;



  let compose _x1 y1 (x2, y2) = (1 + x2), (y1 + y2);;
  let fold x y = Hashtbl.fold compose x y;;

  let compute_operators operator_tbl =
    let x, y =
      fold operator_tbl.tspec_tbl (
        fold operator_tbl.otherop_tbl (
          fold operator_tbl.reserved_tbl (
            fold operator_tbl.knownop_tbl (0,0))))
    in (float_of_int x), (float_of_int y)
  ;;

  let compute_operands operand_tbl =
    let x, y =
      fold operand_tbl.cst_tbl (
        fold operand_tbl.var_tbl (0,0))
    in (float_of_int x), (float_of_int y)
  ;;

  type halstead_metrics = {
    distinct_operators : float;
    total_operators : float;
    distinct_operands : float;
    total_operands : float;
    program_length : float;
    program_volume : float;
    program_level : float;
    vocabulary_size : float;
    difficulty_level : float;
    effort_to_implement : float;
    time_to_implement : float;
    bugs_delivered : float;
  }

  let get_metrics cabs_visitor =
    let operator_tbl = cabs_visitor#get_operator_tbl () in
    let operand_tbl = cabs_visitor#get_operand_tbl () in
    let distinct_operators, total_operators = compute_operators operator_tbl
    and distinct_operands, total_operands = compute_operands operand_tbl in
    let program_length = total_operands +. total_operators in
    let vocabulary_size = distinct_operands +. distinct_operators in
    let log2 x = (log x) /. (log 2.0) in
    let program_volume = program_length *. (log2 vocabulary_size) in
    let difficulty_level =
      (distinct_operators /. 2.) *. (total_operands /. distinct_operands) in
    let program_level = 1. /. difficulty_level in
    let effort_to_implement = program_volume *. difficulty_level in
    let time_to_implement = effort_to_implement /. 18. in
    let bugs_delivered = (effort_to_implement ** (2./.3.)) /. 3000. in
    { distinct_operators = distinct_operators;
      total_operators = total_operators;
      distinct_operands = distinct_operands;
      total_operands = total_operands;
      program_length = program_length;
      program_volume = program_volume;
      program_level = program_level;
      vocabulary_size = vocabulary_size;
      difficulty_level = difficulty_level;
      effort_to_implement = effort_to_implement;
      time_to_implement = time_to_implement;
      bugs_delivered = bugs_delivered;
    }
  ;;

  let to_list hmetrics =
    [ [ "Total operators"; float_to_string hmetrics.total_operators; ];
      [ "Distinct operators"; float_to_string hmetrics.distinct_operators; ];
      [ "Total_operands"; float_to_string hmetrics.total_operands; ];
      [ "Distinct operands"; float_to_string hmetrics.distinct_operands; ];
      [ "Program length"; float_to_string hmetrics.program_length; ];
      [ "Vocabulary size"; float_to_string hmetrics.vocabulary_size; ];
      [ "Program volume"; float_to_string hmetrics.program_volume; ];
      [ "Effort"; float_to_string hmetrics.effort_to_implement; ];
      [ "Program level"; float_to_string hmetrics.program_level; ];
      [ "Difficulty level"; float_to_string hmetrics.difficulty_level; ];
      [ "Time to implement"; float_to_string hmetrics.time_to_implement; ];
      [ "Bugs delivered"; float_to_string hmetrics.bugs_delivered; ];
    ]
  ;;

  let pp_metrics ppf cabs_visitor =
    let metrics = get_metrics cabs_visitor in
    (* Compute the metrics from the informations gathered by the visitor. *)
    let minutes = (int_of_float metrics.time_to_implement) / 60 in
    let _hours, _minutes = minutes / 60, minutes mod 60 in

    let operator_tbl = cabs_visitor#get_operator_tbl () in
    let operand_tbl = cabs_visitor#get_operand_tbl () in

    let dummy_cst cst =
      { expr_loc = Cil_datatype.Location.unknown;
        expr_node = CONSTANT cst;
      }
    and simple_pp_htbl ppf htbl =
      Hashtbl.iter (fun k v -> Format.fprintf ppf "%s: %d@ " k v) htbl in
    (* Halstead metrics' bugs delivered statistics is said to be underapproximated
       for C. Hence the "lower bound" commentary on the output next to "bugs
       delivered".
    *)
    let title = "Halstead metrics"
    and stats = "Global statistics (Halstead)"
    and operator_sec = "Operators"
    and operand_sec = "Operands" in
    Format.fprintf ppf
      "@[<v 0>%a@ %a@ @ \
       %a@ \
       @[<v 2>%a@ %a%a%a%a@]@ \
       @[<v 2>%a@ %a%a@]@ \
       @]"
      (mk_hdr 1) title
      (fun ppf l ->
         List.iter (fun rowl ->
             Format.fprintf ppf "@[<hov>";
             (match rowl with
              | title :: contents ->
                Format.fprintf ppf "%s:@ " title;
                List.iter (fun s -> Format.fprintf ppf "%s@ " s) contents;
              | [] -> ());
             Format.fprintf ppf "@]@ ";
           ) l) (to_list metrics)
      (mk_hdr 1) stats

      (mk_hdr 2) operator_sec
      (* Operators table *)
      simple_pp_htbl operator_tbl.reserved_tbl
      simple_pp_htbl operator_tbl.otherop_tbl
      simple_pp_htbl operator_tbl.knownop_tbl
      (fun ppf htbl ->
         Hashtbl.iter
           (fun k v ->
              Format.fprintf ppf "%a: %d@ " Cprint.print_type_spec k v) htbl)
      operator_tbl.tspec_tbl
      (* Operands *)
      (mk_hdr 2) operand_sec
      simple_pp_htbl operand_tbl.var_tbl
      (fun ppf htbl ->
         Hashtbl.iter
           (fun k v ->
              Format.fprintf ppf "%a: %d@ " Cprint.print_expression (dummy_cst k) v)
           htbl)
      operand_tbl.cst_tbl;
  ;;

  let compute_metrics () =
    (* Run the visitor on all files *)
    let cabs_files = Ast.UntypedFiles.get () in
    let cabs_visitor = new halsteadCabsVisitor in
    List.iter (fun file ->
        ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file))
      cabs_files ;
    Metrics_parameters.result "%a" pp_metrics cabs_visitor

  let get_metrics () =
    let cabs_files = Ast.UntypedFiles.get () in
    let cabs_visitor = new halsteadCabsVisitor in
    List.iter (fun file ->
        ignore (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file))
      cabs_files ;
    get_metrics cabs_visitor
  ;;

end

let compute_on_cabs () =
  try
    let cabs_files = Ast.UntypedFiles.get () in
    let cabs_visitor = new metricsCabsVisitor in
    List.iter (fun file ->
        Metrics_parameters.debug
          ~level:2 "Compute Cabs metrics for file %a@."
          Datatype.Filepath.pretty (fst file);
        ignore
          (Cabsvisit.visitCabsFile (cabs_visitor:>Cabsvisit.cabsVisitor) file);
      )
      cabs_files
    ;
    if Metrics_parameters.ByFunction.get () then
      Metrics_parameters.result
        "@[<v 0>Cabs:@ %a@]" cabs_visitor#pp_detailed_text_metrics ();
    Halstead.compute_metrics ();
  with
  | Ast.NoUntypedAst ->
    Metrics_parameters.warning
      "@[<v 0> Project has no untyped AST. Only metrics over normalized CIL \
       AST are available. \
       @]@."

(*
Local Variables:
compile-command: "make -C ../../.."
End:
*)