Commits

Paweł Wieczorek committed 7cbd64c

big_commit_unmaintainable

Comments (0)

Files changed (18)

 	-Is src/Transformation/While\
 	-Is src/Transformation/MiniML\
 	-Is src/Transformation/CWCPS\
+	-Is src/Architecture\
+	-Is src/Architecture/X86\
+	-Is src/Architecture/Amd64\
+
 
 OCAMLLIBS=#-libs unix
 

src/Analysis/CWCPS/CWCPS_CallGraphOfKnownFunctions.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Analysis
+open Batteries
+open Algebra_Monoid
+open DataModuleTypes
+
+(* HACK *)
+
+type node
+    = Start
+    | Variable of variable
+
+type graph = (node, node) Hashtbl.t
+
+
+let rec analyze_expression is_known current_node graph = function
+(*
+    | EXPR_App (label, VEXPR_TopContinuation, _) ->
+        Hashtbl.add graph current_node End
+*)
+    | EXPR_App (label, VEXPR_Variable called_function, _)
+        when is_known called_function ->
+        Graph.add_edge graph current_node (Variable called_function);
+        print_endline ("Call to known " ^ string_of_variable called_function)
+
+    | EXPR_App (label, VEXPR_Variable called_function, _)
+        when not (is_known called_function) ->
+        print_endline ("Call to escaping " ^ string_of_variable called_function)
+
+    | EXPR_App _ ->
+        ()
+
+    | EXPR_Fix (_, definitions, in_expr) ->
+        let analyze_definition (_, function_name, _, body_expr) =
+            analyze_expression is_known (Variable function_name) graph body_expr
+            in
+        List.iter analyze_definition definitions;
+        analyze_expression is_known current_node graph in_expr
+
+    | EXPR_ConditionPrimOp (label, _, _, _, then_branch, else_branch) ->
+        analyze_expression is_known current_node graph then_branch;
+        analyze_expression is_known current_node graph else_branch
+
+    | EXPR_Switch (label, sel_val, default_branch, branches) ->
+        List.iter (analyze_expression is_known current_node graph) (default_branch::branches)
+
+    | EXPR_ArithmeticBinaryPrimOp (label, _, _, _, _, in_expr)
+    | EXPR_ArithmeticUnaryPrimOp (label, _, _, _, in_expr)
+    | EXPR_Offset (label, _, _, _, in_expr)
+    | EXPR_Select (label, _, _, _, in_expr) 
+    | EXPR_Record (label, _, _, in_expr) ->
+        analyze_expression is_known current_node graph in_expr
+
+
+let analyze program =
+    let graph       = Graph.create () in
+    let is_escaping = CWCPS_VariableUsageAnalysis.EscapingVariablesAnalysis.analyze program in
+    let is_known    = is_escaping |- not in
+    analyze_expression is_known Start graph program;
+    graph
+

src/Analysis/CWCPS/CWCPS_ClosureNeediness.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+open Algebra_Monoid
+open CWCPS_AST
+
+(*
+ * very unmature
+ *)
+
+module MakeMachineDependentAnalysis
+    (ArchitectureSpecification : module type of Architecture_Specification) = struct
+
+    module VariableSetMonoid = SetMonoid(VariableOrderedType)
+    module VariableSetMonoidUtils = MonoidUtils(VariableSetMonoid)
+
+    module WorklistAlgorithm = WorklistAlgorithm.MonoidBased(VariableSetMonoid)
+
+    let free_variables = VariableSetMonoid.embed -| free_variables_of_expression
+
+    let transform_function old_value input = function
+        | Some (CWCPS_VariableUsageAnalysis.BoundByAnalysis.BoundBy_FixDef (_, _, in_expr)) ->
+            VariableSetMonoidUtils.opers
+                [ free_variables in_expr
+                ; old_value
+                ; input
+                ]
+
+        | _ ->
+            VariableSetMonoidUtils.opers
+                [ old_value
+                ; input
+                ]
+
+    let transform (program, bby) node old_value input = match node with
+        | CWCPS_CallGraphOfKnownFunctions.Start ->
+            free_variables program
+
+        | CWCPS_CallGraphOfKnownFunctions.Variable function_name ->
+            transform_function old_value input (bby function_name) 
+    
+    let analyze program = 
+        let call_graph = Graph.weak_reverse (CWCPS_CallGraphOfKnownFunctions.analyze program) in
+        let bby        = CWCPS_VariableUsageAnalysis.BoundByAnalysis.analyze program in
+        let empty      = VariableSet.empty in
+        let trans      = transform (program, bby) in
+        let equal      = VariableSet.equal in
+        let first      = CWCPS_CallGraphOfKnownFunctions.Start in
+        WorklistAlgorithm.Core.compute trans call_graph first
+
+end
+
+module X86_Version = MakeMachineDependentAnalysis(Architecture_X86_Specification)

src/Analysis/CWCPS/CWCPS_SizeSavingAnalysis.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Analysis
+open Batteries
+open Algebra_Monoid
+open DataModuleTypes
+
+(**
+ 
+ References:
+     A.Appel ,,Compiling with continuations''
+ *)
+
+
+module Constants = struct
+
+    let select_size_saving = 1
+
+    let offset_size_saving = 1
+
+    let record_size_saving = 1
+
+    let fix_size_saving    = 1
+
+    let switch_size_saving = 1
+
+    let arithmetic_primop_size_saving = 1
+
+    let condition_primop_size_saving = 1
+
+end
+
+
+(*************************************************************************************************
+ *
+ ************************************************************************************************)
+
+
+module IntMonoid = PreparedMonoids.IntSumMonoid
+
+let analyze_node = function
+    | EXPR_Select(label, offset, value, result, in_expr) ->
+        IntMonoid.opers
+            [ Constants.select_size_saving
+            ]
+
+    | EXPR_Offset(label, offset, value, result, in_expr) ->
+        IntMonoid.opers
+            [ Constants.offset_size_saving
+            ]
+
+    | EXPR_Record(label, fields, result, in_expr) ->
+        IntMonoid.opers
+            [ Constants.record_size_saving 
+            ; List.length fields
+            ]
+
+    | EXPR_App(label, function_value, argument_values) ->
+        IntMonoid.opers
+            [ Constants.select_size_saving
+            ; List.length argument_values
+            ]
+
+    | EXPR_Fix(reclabel, definitions, in_expr) ->
+        IntMonoid.opers
+            [ Constants.select_size_saving
+            ; List.length definitions
+            ]
+
+    | EXPR_Switch(label, value, default_branch, branches) ->
+        IntMonoid.opers
+            [ Constants.switch_size_saving
+            ; List.length branches
+            ]
+
+    | EXPR_ArithmeticBinaryPrimOp(label, primop, input1, input2, result, in_expr) ->
+        IntMonoid.opers
+            [ Constants.arithmetic_primop_size_saving
+            ]
+
+    | EXPR_ArithmeticUnaryPrimOp(label, primop, input, result, in_expr) ->
+        IntMonoid.opers
+            [ Constants.arithmetic_primop_size_saving
+            ]
+        
+
+    | EXPR_ConditionPrimOp(label, primop, input1, input2, result, in_expr) ->
+        IntMonoid.opers
+            [ Constants.condition_primop_size_saving
+            ]
+
+let analyze tm =
+    let module M = MonoidBasedAnalysis(IntMonoid) in
+    M.Gather.gather analyze_node tm
+

src/Analysis/CWCPS/CWCPS_VariableUsageAnalysis.ml

         | _ ->
             FunMonoid.neutral
 
+    let analyze_as_monoid =
+        let module M = MonoidBasedAnalysis(FunMonoid) in
+        M.Gather.gather analyze_node 
+
     let analyze =
-        let module M = MonoidBasedAnalysis(FunMonoid) in
-        M.Gather.gather analyze_node
+        analyze_as_monoid
+        |- FunMonoid.call
+        
 
 end
 

src/Architecture/Amd64/Architecture_Amd64_Specification.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+let number_of_general_purpose_registers = 16
+

src/Architecture/Architecture_Specification.mli

+
+val architecture_name : string
+
+val number_of_general_purpose_registers : int

src/Architecture/X86/Architecture_X86_Specification.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+
+let architecture_name = "x86"
+
+let number_of_general_purpose_registers = 8
+

src/Language/CWCPS/CWCPS_AST.ml

 
 let expr_equal expr1 expr2 = __equal () (expr1, expr2)
 
+(*************************************************************************************************
+ * Set of free variables
+ ************************************************************************************************)
+
+module VariableSet = Set.Make(VariableOrderedType)
+
+let free_variable_of_value_expression = function
+    | VEXPR_Variable v ->
+        VariableSet.singleton v
+
+    | _ ->
+        VariableSet.empty
+
+let rec free_variables_of_expression = function
+        | EXPR_App (label, fun_val, arg_vals) ->
+            fun_val :: arg_vals
+            |> List.fold_left
+                (fun set vexpr -> VariableSet.union set (free_variable_of_value_expression vexpr))
+                VariableSet.empty
+            
+        | EXPR_Switch (label, sel_val, default_branch, branches) ->
+            default_branch :: branches
+            |> List.fold_left
+                (fun set vexpr -> VariableSet.union set (free_variables_of_expression vexpr))
+                VariableSet.empty
+
+        | EXPR_Fix (fix_label, definitions, in_expr) ->
+            let from_def (_, _, _, body_expr) = free_variables_of_expression body_expr
+                in
+
+            let def_name (_, name, _, _) = name
+                in
+
+            let fvs =
+                List.fold_left
+                    VariableSet.union 
+                    VariableSet.empty
+                    (free_variables_of_expression in_expr :: List.map from_def definitions)
+                in
+
+            let bvs = List.map def_name definitions
+                in
+
+            List.fold_left (fun set v -> VariableSet.remove v set) fvs bvs
+
+        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
+            in_expr
+            |> free_variables_of_expression
+            |> VariableSet.remove result
+
+        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
+            in_expr
+            |> free_variables_of_expression
+            |> VariableSet.remove result
+
+        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
+            (then_branch, else_branch)
+            |> Tuple2.map free_variables_of_expression
+            |> uncurry VariableSet.union
+
+        | EXPR_Offset (label, offset, value, result, in_expr) ->
+            in_expr
+            |> free_variables_of_expression
+            |> VariableSet.remove result
+
+        | EXPR_Select (label, offset, value, result, in_expr) ->
+            in_expr
+            |> free_variables_of_expression
+            |> VariableSet.remove result
+
+        | EXPR_Record (label, fields, result, in_expr) ->
+            in_expr
+            |> free_variables_of_expression
+            |> VariableSet.remove result

src/Language/CWCPS/CWCPS_Analysis.ml

 open Batteries
 
 (*************************************************************************************************
- * Lattice based 
+ * Monoid based 
  ************************************************************************************************)
 
 module MonoidBasedAnalysis (M : Monoid) = struct
     end
 
 end
+
+(*************************************************************************************************
+ * Imperative based
+ ************************************************************************************************)
+

src/Language/MiniML/MiniML_Eval.ml

         in let function_value = eval_expression context function_expression
 
         in let (argument_variable, body_expression, closure_environment) = force_closure function_value in
+        let closure_environment = Environment.clone closure_environment in
         let new_context = Context.make_context_from_environment context closure_environment in
         let cont () = eval_expression new_context body_expression in
         Context.with_extended_environment new_context argument_variable argument_value cont

src/Lib/Algebra/Algebra_Monoid.ml

                 |> SV.enum
                 |> Enum.get
 
+        let embed x = BotSet x
     end
 
     include Raw
+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
+type 'a digraph = ('a, 'a list) Hashtbl.t
+
+
+let __add htbl k x = 
+    try 
+        let xs = Hashtbl.find htbl k in
+        Hashtbl.replace htbl k (x::xs)
+    with _ ->
+        Hashtbl.replace htbl k [x]
+
+let __remove htbl k x =
+    try
+        let xs = Hashtbl.find htbl k in
+        Hashtbl.replace htbl k (List.filter ( (=) x ) xs)
+    with _ ->
+        ()
+
+let create () = (Hashtbl.create 1027, Hashtbl.create 1027)
+
+let add_edge (graph,revgraph) parent child = 
+    __add graph    parent child;
+    __add revgraph child parent
+
+let remove_edge (graph, revgraph) parent child =
+    __remove graph parent child;
+    __remove revgraph child parent
+
+let get_children (graph, revgraph) parent =
+    try
+        Hashtbl.find graph parent
+    with _ ->
+        []
+
+let get_parents (graph, revgraph) child =
+    try
+        Hashtbl.find revgraph child
+    with _ ->
+        []
+
+let iter (graph, revgraph) f =
+    Hashtbl.iter (fun k xs -> f k; List.iter f xs) graph
+
+let weak_reverse (graph, revgraph) = (revgraph, graph)
+
+let reverse (graph, revgraph) = (Hashtbl.copy revgraph, Hashtbl.copy graph)

src/Lib/Util/Util.ml

     let h     = open_in fname in
     Marshal.from_channel h
 
+
+type ('a,'b) either
+    = Left of 'a
+    | Right of 'b
+
+

src/Lib/WorklistAlgorithm.ml

 open Batteries
 
-type 'a graph  = ('a, 'a) Hashtbl.t
-
 type ('a, 'b) result = ('a,'b) Hashtbl.t
 
-module Core = struct
 
+module MonoidBased (M : Algebra_Monoid.Monoid) = struct
 
-    let rec loop f eq graph result queue = 
-        let node = Queue.take queue in
-        let old_value  = Hashtbl.find result node in
-        let new_value  = f node old_value in
-        if not (eq old_value new_value)
-        then begin
-            let affected_nodes = Hashtbl.find_all graph node in
-            List.iter (fun x -> Queue.push x queue) affected_nodes;
-            Hashtbl.replace result node new_value
-        end;
-        loop f eq graph result queue
 
-    let compute f eq graph empty first =
-        let queue         = Queue.create () in
-        let result        = Hashtbl.create 512 in
-        let set_empty y x = Hashtbl.replace result x empty; Hashtbl.replace result y empty in
-        Hashtbl.iter set_empty graph;
-        Queue.push first queue;
-        try 
-            loop f eq graph result queue
-        with Queue.Empty ->
-            result
+    module Core = struct
+        module Utils = Algebra_Monoid.MonoidUtils(M)
+
+        let compute f graph first =
+            let queue         = Queue.create () in
+            let result        = Hashtbl.create 512 in
+            let set_empty node =
+                    Hashtbl.replace result node M.neutral
+                    in
+            Graph.iter graph set_empty ;
+            Queue.push first queue;
+            try 
+
+                let rec loop () = 
+                    let node      = Queue.take queue in
+                    let old_value = Hashtbl.find result node in
+                    let parents   = Graph.get_parents graph node in
+                    let input     = Utils.oper_map (Hashtbl.find result) parents in
+                    let new_value = f node old_value input in
+                    if not (M.equal old_value new_value)
+                    then begin
+                        let children = Graph.get_children graph node in
+                        List.iter (fun node -> Queue.push node queue) children;
+                        Hashtbl.replace result node new_value
+                    end;
+                    loop ()
+                    in
+
+                loop ()
+            with Queue.Empty ->
+                result
+
+    end
+
+    module Simple = struct
+
+        let compute f = Core.compute (fun _ _ -> f)
+
+    end
+
+
+    
 
 end
-
-module Simple = struct
-
-    let compute f = Core.compute (fun _ -> f)
-
-end
-
-
-module HashtblPackedFunction = struct
-
-    type ('a, 'b) ftype = ('a, 'b -> 'b) Hashtbl.t
-
-    let compute fs eq graph empty first =
-        let f l           = Hashtbl.find l in
-        Core.compute f eq graph empty first
-
-end
 open CWCPS_RecordUsageOptimization
 open CWCPS_UncurryFunctionsTransformation
 open CWCPS_SizeSavingAnalysis
-open Algebra_Monoid
-open Enumerators
-open WorklistAlgorithm
+open CWCPS_ClosureNeediness
+open CWCPS_NaiveClosureConversion
 
 (************************************************************************************************
  * About command

src/Transformation/CWCPS/CWCPS_NaiveClosureConversion.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+open CWCPS_AST
+open CWCPS_Transformation
+
+module MachineDependent(ArchitectureSpecification : module type of Architecture_Specification) = struct
+
+    
+    let does_definition_need_closure f_need_closure (_, name, _, _) = f_need_closure name
+
+    let generate_closure f_vriables xs = 
+        let 
+
+    let rec convert_node f_variables f_need_closure = function
+        | EXPR_Fix(reclabel, definitions, in_expr) ->
+            let (definitions_with_closure, definitions_without_closure) =
+                List.partition (does_definition_need_closure f_need_closure) definitions
+                in
+
+            let changed_definitions = generate_closure f_variables definitions_with_closure in
+            Replace (EXPR_Fix (reclabel, changed_definitions @ definitions_without_closure, in_expr))
+
+        | _ ->
+            raise Exit
+
+
+end

templates/template.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.