Source

Opifex / src / Analysis / CWCPS / CWCPS_VariableUsageAnalysis.ml

Full commit
(*
 * Opifex
 *
 * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
 *)

open CWCPS_AST
open CWCPS_Transformation
open Batteries
open Algebra_Monoid


(*************************************************************************************************
 * Usage counting
 *
 * VariableUsageCount_FunMonoid
 *      Variable -> Monoid<Z, +, 0>
 ************************************************************************************************)

module VariableUsageCount_FunMonoid = PreparedMonoids.SumInt_FunMonoid(VariableOrderedType)

module UsageCounting = struct

    let handle_values xs =
        xs
        |> List.filter_map get_variable
        |> VariableUsageCount_FunMonoid.from_arg_list_with_val 1

    let __analyze = function
        | EXPR_App (label, fun_val, arg_vals) ->
            fun_val::arg_vals
            |> handle_values

        | EXPR_Switch (label, sel_val, default_branch, branches) ->
            [sel_val]
            |> handle_values

        | EXPR_Fix (reclabel, definitions, in_expr) ->
            VariableUsageCount_FunMonoid.neutral

        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
            [arg1; arg2]
            |> handle_values

        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
            [arg]
            |> handle_values

        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
            [arg1; arg2]
            |> handle_values

    let analyze tm =
        let module M = MonoidBased(VariableUsageCount_FunMonoid) in
        M.Gather.gather __analyze tm
        |> VariableUsageCount_FunMonoid.call

end

(*************************************************************************************************
 * Escaping variables
 *
 * EscapingVariable_FunMonoid
 *      Variable -> Monoid<Bool, or, false>
 ************************************************************************************************)

module EscapingVariable_FunMonoid = PreparedMonoids.SumBool_FunMonoid(VariableOrderedType)

module EscapingVariables = struct

    let handle_values xs =
        xs
        |> List.filter_map get_variable
        |> EscapingVariable_FunMonoid.from_arg_list_with_val true

    let __analyze = function
        | EXPR_App (label, fun_val, arg_vals) ->
            arg_vals
            |> handle_values

        | _ ->
            EscapingVariable_FunMonoid.neutral

    let analyze =
        let module M = MonoidBased(EscapingVariable_FunMonoid) in
        M.Gather.gather __analyze

end

(*************************************************************************************************
 ************************************************************************************************)

module BoundBy_FunMonoid = PreparedMonoids.SumBool_FunMonoid(VariableOrderedType)

module BoundByAnalysis = struct

    type t
        = BoundBy_FixDef of label

end

(*************************************************************************************************
 ************************************************************************************************)

module Compose = struct

    type t =
        { usage_count : variable -> int
        ; escapes     : variable -> bool
        ; known       : variable -> bool
        }

    module Monoid = Tuple2Monoid
            (VariableUsageCount_FunMonoid)
            (EscapingVariable_FunMonoid)

    let __analyze = Monoid.combine
        UsageCounting.__analyze
        EscapingVariables.__analyze

    let analyze tm =
        let module M = MonoidBased(Monoid) in
        let (mon_usage_count, mon_escapes) = M.Gather.gather __analyze tm in
        { usage_count   = VariableUsageCount_FunMonoid.call mon_usage_count
        ; escapes       = EscapingVariable_FunMonoid.call   mon_escapes
        ; known         = EscapingVariable_FunMonoid.call   mon_escapes |- not
        }

end

(*************************************************************************************************
 ************************************************************************************************)