Commits

Paweł Wieczorek committed a9c11f3

added BoundBy analysis

Comments (0)

Files changed (3)

src/Analysis/CWCPS/CWCPS_VariableUsageAnalysis.ml

 open CWCPS_Transformation
 open Batteries
 open Algebra_Monoid
-
+open DataModuleTypes
 
 (*************************************************************************************************
  * Usage counting
  *      Variable -> Monoid<Z, +, 0>
  ************************************************************************************************)
 
-module VariableUsageCount_FunMonoid = PreparedMonoids.SumInt_FunMonoid(VariableOrderedType)
 
 module UsageCounting = struct
 
+    module FunMonoid = PreparedMonoids.SumInt_FunMonoid(VariableOrderedType)
+
     let handle_values xs =
         xs
         |> List.filter_map get_variable
-        |> VariableUsageCount_FunMonoid.from_arg_list_with_val 1
+        |> FunMonoid.from_arg_list_with_val 1
 
     let __analyze = function
         | EXPR_App (label, fun_val, arg_vals) ->
             |> handle_values
 
         | EXPR_Fix (reclabel, definitions, in_expr) ->
-            VariableUsageCount_FunMonoid.neutral
+            FunMonoid.neutral
 
         | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
             [arg1; arg2]
             |> handle_values
 
     let analyze tm =
-        let module M = MonoidBased(VariableUsageCount_FunMonoid) in
+        let module M = MonoidBased(FunMonoid) in
         M.Gather.gather __analyze tm
-        |> VariableUsageCount_FunMonoid.call
+        |> FunMonoid.call
 
 end
 
  *      Variable -> Monoid<Bool, or, false>
  ************************************************************************************************)
 
-module EscapingVariable_FunMonoid = PreparedMonoids.SumBool_FunMonoid(VariableOrderedType)
 
-module EscapingVariables = struct
+module EscapingVariablesAnalysis = struct
+
+    module FunMonoid = PreparedMonoids.SumBool_FunMonoid(VariableOrderedType)
 
     let handle_values xs =
         xs
         |> List.filter_map get_variable
-        |> EscapingVariable_FunMonoid.from_arg_list_with_val true
+        |> FunMonoid.from_arg_list_with_val true
 
     let __analyze = function
         | EXPR_App (label, fun_val, arg_vals) ->
             |> handle_values
 
         | _ ->
-            EscapingVariable_FunMonoid.neutral
+            FunMonoid.neutral
 
     let analyze =
-        let module M = MonoidBased(EscapingVariable_FunMonoid) in
+        let module M = MonoidBased(FunMonoid) in
         M.Gather.gather __analyze
 
 end
 
 (*************************************************************************************************
+ * BoundBy analysis
+ *
+ * BoundBy_FunMonoid
+ *      Variable -> OneShotPartialMonoid<BoundBy>
  ************************************************************************************************)
 
-module BoundBy_FunMonoid = PreparedMonoids.SumBool_FunMonoid(VariableOrderedType)
-
 module BoundByAnalysis = struct
 
-    type t
-        = BoundBy_FixDef of label
+    module Type = struct
+
+        type t =
+            BoundBy_FixDef of label * variable * variable list * expression
+
+        let equal (a : t) b = a = b
+
+    end
+
+    module FunMonoid = FunMonoid(VariableOrderedType)(OneShotPartialMonoid(Type))
+
+    include Type
+
+    let from_list xs =
+        xs
+        |> List.map (fun (a,b) -> (a, Some b))
+        |> FunMonoid.from_list
+
+    let __analyze = function
+        | EXPR_Fix (reclabel, definitions, in_expr) ->
+            let f (deflabel, defname, defargs, defbody) =
+                (defname, BoundBy_FixDef (deflabel, defname, defargs, defbody))
+                in
+
+            List.map f definitions
+            |> from_list
+
+        | _ ->
+            FunMonoid.neutral
+
+    let analyze tm = 
+        let module M = MonoidBased(FunMonoid) in
+        M.Gather.gather __analyze tm
+        |> FunMonoid.call
 
 end
 
         { usage_count : variable -> int
         ; escapes     : variable -> bool
         ; known       : variable -> bool
+        ; bound_by    : variable -> BoundByAnalysis.t option
         }
 
-    module Monoid = Tuple2Monoid
-            (VariableUsageCount_FunMonoid)
-            (EscapingVariable_FunMonoid)
+    module Monoid = Tuple3Monoid
+            (UsageCounting.FunMonoid)
+            (EscapingVariablesAnalysis.FunMonoid)
+            (BoundByAnalysis.FunMonoid)
 
     let __analyze = Monoid.combine
         UsageCounting.__analyze
-        EscapingVariables.__analyze
+        EscapingVariablesAnalysis.__analyze
+        BoundByAnalysis.__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
+        let (mon_usage_count, mon_escapes, mon_bound_by) = M.Gather.gather __analyze tm in
+
+        { usage_count   = UsageCounting.FunMonoid.call      mon_usage_count
+        ; escapes       = EscapingVariablesAnalysis.FunMonoid.call  mon_escapes
+        ; known         = EscapingVariablesAnalysis.FunMonoid.call  mon_escapes |- not
+        ; bound_by      = BoundByAnalysis.FunMonoid.call    mon_bound_by
         }
 
 end

src/Lib/Algebra/Algebra_Monoid.ml

  * Tuple2 monoid
  ************************************************************************************************)
 
-
 module Tuple2Monoid (M1 : Monoid) (M2 : Monoid) = struct
 
     module Raw = struct
 end
 
 (*************************************************************************************************
+ * Tuple3 monoid
+ ************************************************************************************************)
+
+module Tuple3Monoid (M1 : Monoid) (M2 : Monoid) (M3 : Monoid) = struct
+
+    module Raw = struct
+
+        type t = M1.t * M2.t * M3.t
+
+        let equal (a1,b1,c1) (a2,b2,c2) =
+            M1.equal a1 a2 && M2.equal b1 b2 && M3.equal c1 c2
+
+        let neutral = (M1.neutral, M2.neutral, M3.neutral)
+
+        let oper (a1,b1,c1) (a2,b2,c2) = (M1.oper a1 a2, M2.oper b1 b2, M3.oper c1 c2)
+
+        let combine f g h a = (f a, g a, h a)
+
+    end
+
+    include Raw
+    include MonoidUtils(Raw)
+
+end
+
+(*************************************************************************************************
  * The option (lifted) monoid
  ************************************************************************************************)
 

src/Lib/DataModuleTypes.ml

     let equal a b = M.compare a b == 0
 
 end
+
+module EqTypeFromBuiltIn ( M : sig type t end ) = struct
+
+    type t = M.t
+
+    let equal a b = a = b
+
+end