Commits

Paweł Wieczorek committed 9a67e71

Lang_CWCPS _Analysis and _Transformations

  • Participants
  • Parent commits a03c29f
  • Branches 2014_03_16_cleaning

Comments (0)

Files changed (33)

File source/Languages/Lang_CWCPS.mlpack

 Eval
 PrettyPrinter
 Helper
-Analysis
 AnalysisFramework
 Parser
 Lexer
 TransformationFramework
-Transformation

File source/Languages/Lang_CWCPS/Analysis.mlpack

-CallGraphOfKnownFunctions
-ClosureNeediness
-SizeSavingAnalysis
-VariableUsageAnalysis

File source/Languages/Lang_CWCPS/Analysis/CallGraphOfKnownFunctions.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open AnalysisFramework
-open Batteries
-open Lib_Algebra.Monoid
-open DataModuleTypes
-
-(*********************************************************************************************************************
- * Types
- ********************************************************************************************************************)
-
-type node
-    = Start
-    | Variable of variable
-
-type graph = (node, node) Hashtbl.t
-
-(*********************************************************************************************************************
- * Implementation
- ********************************************************************************************************************)
-
-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
-
-(*********************************************************************************************************************
- * Entry point
- ********************************************************************************************************************)
-
-let analyze program =
-    let graph       = Graph.create () in
-    let is_escaping = VariableUsageAnalysis.EscapingVariablesAnalysis.analyze program in
-    let is_known    = is_escaping %> not in
-    analyze_expression is_known Start graph program;
-    graph
-

File source/Languages/Lang_CWCPS/Analysis/ClosureNeediness.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-open Lib_Algebra.Monoid
-open AST
-
-(*
- * very unmature
- *)
-
-(*********************************************************************************************************************
- * Implementation
- ********************************************************************************************************************)
-
-(*
-module MakeMachineDependentAnalysis
-    (ArchitectureSpecification : module type of Architecture_Specification) = struct
-
-    module VariableSetMonoid = SetMonoid(VariableOrderedType)
-    module VariableSetMonoidUtils = MonoidUtils(VariableSetMonoid)
-
-    module WorklistAlgorithm = Lib_Algebra.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 trans      = transform (program, bby) in
-        let first      = CWCPS_CallGraphOfKnownFunctions.Start in
-        WorklistAlgorithm.Core.compute trans call_graph first
-
-end
-
-(*********************************************************************************************************************
- * Machine specialization
- ********************************************************************************************************************)
-
-module X86_Version = MakeMachineDependentAnalysis(Architecture_X86_Specification)
-
-*)

File source/Languages/Lang_CWCPS/Analysis/SizeSavingAnalysis.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open AnalysisFramework
-open Batteries
-open Lib_Algebra.Monoid
-open DataModuleTypes
-
-(**
- 
- References:
-     A.Appel ,,Compiling with continuations''
- *)
-
-(*********************************************************************************************************************
- * Constants
- ********************************************************************************************************************)
-
-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
-
-(*********************************************************************************************************************
- * Data
- ********************************************************************************************************************)
-
-module IntMonoid = PreparedMonoids.IntSumMonoid
-
-(*********************************************************************************************************************
- * Implementation
- ********************************************************************************************************************)
-
-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
-            ]
-
-(*********************************************************************************************************************
- * Entry point
- ********************************************************************************************************************)
-
-let analyze tm =
-    let module M = MonoidBasedAnalysis(IntMonoid) in
-    M.Gather.gather analyze_node tm
-

File source/Languages/Lang_CWCPS/Analysis/VariableUsageAnalysis.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open AnalysisFramework
-open Batteries
-open Lib_Algebra.Monoid
-open DataModuleTypes
-
-(*********************************************************************************************************************
- * Usage counting
- *
- * VariableUsageCount_FunMonoid
- *      Variable -> Algebra.Monoid<Z, +, 0>
- ********************************************************************************************************************)
-
-module UsageCountingAnalysis = struct
-
-    module FunMonoid = PreparedMonoids.SumInt_FunMonoid(VariableOrderedType)
-
-    let handle_values xs =
-        xs
-        |> List.filter_map get_variable
-        |> FunMonoid.from_arg_list_with_val 1
-
-    let analyze_node = 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) ->
-            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
-
-        | EXPR_Offset (label, offset, arg, result, in_expr)
-        | EXPR_Select (label, offset, arg, result, in_expr) ->
-            [arg] 
-            |> handle_values
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            fields
-            |> List.map fst
-            |> handle_values
-
-    let analyze tm =
-        let module M = MonoidBasedAnalysis(FunMonoid) in
-        M.Gather.gather analyze_node tm
-        |> FunMonoid.call
-
-end
-
-(*********************************************************************************************************************
- * Escaping variables
- *
- * EscapingVariable_FunMonoid
- *      Variable -> Algebra.Monoid<Bool, or, false>
- ********************************************************************************************************************)
-
-module EscapingVariablesAnalysis = struct
-
-    module FunMonoid = PreparedMonoids.SumBool_FunMonoid(VariableOrderedType)
-
-    let handle_values xs =
-        xs
-        |> List.filter_map get_variable
-        |> FunMonoid.from_arg_list_with_val true
-
-    let analyze_node = function
-        | EXPR_App (label, fun_val, arg_vals) ->
-            arg_vals
-            |> handle_values
-
-        | _ ->
-            FunMonoid.neutral
-
-    let analyze_as_monoid =
-        let module M = MonoidBasedAnalysis(FunMonoid) in
-        M.Gather.gather analyze_node 
-
-    let analyze =
-        analyze_as_monoid
-        %> FunMonoid.call
-        
-
-end
-
-(*********************************************************************************************************************
- * BoundBy analysis
- *
- * BoundBy_FunMonoid
- *      Variable -> OneShotPartialAlgebra.Monoid<BoundBy>
- ********************************************************************************************************************)
-
-module BoundByAnalysis = struct
-
-    module Type = struct
-
-        type t
-             = BoundBy_FixDef of label * variable list * expression
-             | BoundBy_Record of label * record_field list
-             | BoundBy_Select of label * int * value_expression
-             | BoundBy_Offset of label * int * value_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_node = function
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            let f (deflabel, defname, defargs, defbody) =
-                (defname, BoundBy_FixDef (deflabel, defargs, defbody))
-                in
-
-            List.map f definitions
-            |> from_list
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            [(result, BoundBy_Record (label, fields))]
-            |> from_list
-
-        | EXPR_Select (label, offset, value, result, in_expr) ->
-            [(result, BoundBy_Select (label, offset, value))]
-            |> from_list
-
-        | EXPR_Offset (label, offset, value, result, in_expr) ->
-            [(result, BoundBy_Offset (label, offset, value))]
-            |> from_list
-
-        | _ ->
-            FunMonoid.neutral
-
-    let analyze_as_monoid tm = 
-        let module M = MonoidBasedAnalysis(FunMonoid) in
-        M.Gather.gather analyze_node tm
-
-    let analyze = analyze_as_monoid %> FunMonoid.call
-
-end
-
-(*********************************************************************************************************************
- * Combined
- ********************************************************************************************************************)
-
-module Combined = struct
-
-    type t =
-        { usage_count : variable -> int
-        ; escapes     : variable -> bool
-        ; known       : variable -> bool
-        ; bound_by    : variable -> BoundByAnalysis.t option
-        }
-
-    module Monoid = Tuple3Monoid
-            (UsageCountingAnalysis.FunMonoid)
-            (EscapingVariablesAnalysis.FunMonoid)
-            (BoundByAnalysis.FunMonoid)
-
-    let analyze_node = Monoid.combine
-        UsageCountingAnalysis.analyze_node
-        EscapingVariablesAnalysis.analyze_node
-        BoundByAnalysis.analyze_node
-
-    let analyze tm =
-        let module M = MonoidBasedAnalysis(Monoid) in
-        let (mon_usage_count, mon_escapes, mon_bound_by) = M.Gather.gather analyze_node tm in
-
-        { usage_count   = UsageCountingAnalysis.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
-
-(*********************************************************************************************************************
- * Entry point
- ********************************************************************************************************************)
-
-include Combined
-
-let analyze = Combined.analyze
-
-

File source/Languages/Lang_CWCPS/Transformation.mlpack

-BetaContractionOptimization
-ConditionalJumpsOptimization
-ConstantFoldingOptimization
-EtaConversionTransformation
-Hoisting
-NaiveClosureConversion
-RecordUsageOptimization
-RegisterSpilling
-RemoveDeadCodeOptimization
-UncurryFunctionsTransformation

File source/Languages/Lang_CWCPS/Transformation/BetaContractionOptimization.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-open Analysis.VariableUsageAnalysis
-
-(*********************************************************************************************************************
- * Unused definitions
- ********************************************************************************************************************)
-
-module BetaContraction = struct
-
-    let try_beta_reduction fname actual_args = function
-        | Some (BoundByAnalysis.BoundBy_FixDef (_, formal_args, body)) ->
-            let sb = List.combine formal_args actual_args in
-            Replace (subst sb body)
-            
-        | _ ->
-            NoChange
-
-    let transformation enumerators variable_usage = function
-        | EXPR_App (label, VEXPR_Variable fname, actual_args)
-          when variable_usage.usage_count fname = 1 && variable_usage.known fname ->
-            let bby = variable_usage.bound_by fname in
-            try_beta_reduction fname actual_args bby
-
-        | _ ->
-            NoChange
-end
-
-(*********************************************************************************************************************
- * 
- ********************************************************************************************************************)
-
-let bottomup_transformations = 
-    [ BetaContraction.transformation
-    ]
-
-let transform = bottomups_with_analysis
-    Analysis.VariableUsageAnalysis.analyze
-    bottomup_transformations 
-

File source/Languages/Lang_CWCPS/Transformation/ConditionalJumpsOptimization.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-
-(*********************************************************************************************************************
- * Arithmetic Simplifier
- ********************************************************************************************************************)
-
-(* TODO: use usage-counting to check if inlined function is dedicated for our jump *)
-module ArithmeticSimplifier = struct
-    open Analysis.VariableUsageAnalysis.BoundByAnalysis
-
-    let check_called_function = function
-        | BoundBy_FixDef(_, _, EXPR_Switch(label, selval, default_branch, [zero_branch])) ->
-            Some (default_branch, zero_branch)
-
-        | _ ->
-            None
-
-    let check_branches f_bby = function
-        | (EXPR_App(label1, VEXPR_Variable fname1, [VEXPR_Integer 1])
-          ,EXPR_App(label2, VEXPR_Variable fname2, [VEXPR_Integer 0]))
-          when fname1 = fname2 ->
-            Option.bind (f_bby fname1) check_called_function 
-
-        | _ ->
-            None
-            
-
-    let transform_node enumerators f_bby = function
-        | EXPR_ConditionPrimOp(label, primop, arg1, arg2, then_branch, else_branch) ->
-            begin match check_branches f_bby (then_branch, else_branch) with
-            | Some (new_then_branch, new_else_branch) ->
-                Replace (EXPR_ConditionPrimOp(label, primop, arg1, arg2, new_then_branch, new_else_branch))
-
-            | None ->
-                NoChange
-            end
-
-        | _ ->
-            NoChange
-
-end
-
-(*********************************************************************************************************************
- * Constant folding
- ********************************************************************************************************************)
-
-let bottomup_transformations = 
-    [ ArithmeticSimplifier.transform_node
-    ]
-
-let transform = bottomups_with_analysis
-    Analysis.VariableUsageAnalysis.BoundByAnalysis.analyze
-    bottomup_transformations
-

File source/Languages/Lang_CWCPS/Transformation/ConstantFoldingOptimization.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-
-(*********************************************************************************************************************
- * Arithmetic Simplifier
- ********************************************************************************************************************)
-
-module ArithmeticSimplifier = struct
-
-    let substitute_vexpr result i = Substitute [ (result, i) ]
-
-    let substitute_int result i   = substitute_vexpr result (VEXPR_Integer i)
-
-
-    let transform_binary = function
-
-        (* compute *)
-
-        | (PRIMOP_Add, VEXPR_Integer a, VEXPR_Integer b, result) ->
-            substitute_int result (a+b)
-
-        | (PRIMOP_Sub, VEXPR_Integer a, VEXPR_Integer b, result) ->
-            substitute_int result (a-b)
-
-        | (PRIMOP_Mul, VEXPR_Integer a, VEXPR_Integer b, result) ->
-            substitute_int result (a*b)
-
-        | (PRIMOP_Div, VEXPR_Integer a, VEXPR_Integer b, result) when b <> 0 ->
-            substitute_int result (a/b)
-
-        | (PRIMOP_Mod, VEXPR_Integer a, VEXPR_Integer b, result) when b <> 0 ->
-            substitute_int result (a mod b)
-
-        (* zeros and ones *)
-
-        | (PRIMOP_Add, a, VEXPR_Integer 0, result) 
-        | (PRIMOP_Add, VEXPR_Integer 0, a, result) ->
-            substitute_vexpr result a
-
-        | (PRIMOP_Mul, a, VEXPR_Integer 1, result) 
-        | (PRIMOP_Mul, VEXPR_Integer 1, a, result) ->
-            substitute_vexpr result a
-
-        | (PRIMOP_Mul, a, VEXPR_Integer 0, result) 
-        | (PRIMOP_Mul, VEXPR_Integer 0, a, result) ->
-            substitute_int result 0
-
-        | (PRIMOP_Div, a, VEXPR_Integer 1, result) ->
-            substitute_vexpr result a
-
-        | (PRIMOP_Mod, a, VEXPR_Integer 1, result) ->
-            substitute_int result 0
-
-        (* other *)
-
-        | _ ->
-            NoChange
-
-    let transform_node _ = function
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            transform_binary (primop, arg1, arg2, result)
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, branch) ->
-            NoChange
-
-        | _ ->
-            NoChange
-
-
-    let transform_expression = topdown transform_node
-
-end
-
-(*********************************************************************************************************************
- * Bitwise Arithmetic Simplifier
- ********************************************************************************************************************)
-
-module BitwiseArithmeticSimplifier = struct
-
-    let substitute_vexpr result i = Substitute [ (result, i) ]
-
-    let substitute_int result i   = substitute_vexpr result (VEXPR_Integer i)
-
-
-    let transform_binary = function
-
-        (* compute *)
-
-        | (PRIMOP_And, VEXPR_Integer a, VEXPR_Integer b, result) ->
-            substitute_int result (a land b)
-
-        | (PRIMOP_Or, VEXPR_Integer a, VEXPR_Integer b, result) ->
-            substitute_int result (a lor b)
-
-        | (PRIMOP_Xor, VEXPR_Integer a, VEXPR_Integer b, result) ->
-            substitute_int result (a lxor b)
-
-        (* zeros and ones *)
-
-        | (PRIMOP_And, a, VEXPR_Integer 0, result) 
-        | (PRIMOP_And, VEXPR_Integer 0, a, result) ->
-            substitute_vexpr result a
-
-        | (PRIMOP_Or, a, VEXPR_Integer 0, result) 
-        | (PRIMOP_Or, VEXPR_Integer 0, a, result) ->
-            substitute_vexpr result a
-
-        | (PRIMOP_Xor, a, VEXPR_Integer 0, result) 
-        | (PRIMOP_Xor, VEXPR_Integer 0, a, result) ->
-            substitute_vexpr result a
-
-        (* other *)
-
-        | _ ->
-            NoChange
-
-    let transform_node _ = function
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            transform_binary (primop, arg1, arg2, result)
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, branch) ->
-            NoChange
-
-        | _ ->
-            NoChange
-
-
-    let transform_expression = topdown transform_node
-
-end
-
-(*********************************************************************************************************************
- * Bitwise Arithmetic Simplifier
- ********************************************************************************************************************)
-
-module ConditionSimplifier = struct
-
-    let substitute_vexpr result i = Substitute [ (result, i) ]
-
-    let substitute_int result i   = substitute_vexpr result (VEXPR_Integer i)
-
-    let transform_condition = function
-        | (primop, VEXPR_Integer a, VEXPR_Integer b, then_branch, else_branch) ->
-            if eval_condition_primitive_operation primop a b
-            then Replace then_branch
-            else Replace else_branch
-
-        | _ ->
-            NoChange
-
-    let transform_node _ = function
-        | EXPR_ConditionPrimOp (label, primop, val1, val2, then_branch, else_branch) ->
-            transform_condition (primop, val1, val2, then_branch, else_branch)
-
-        | _ ->
-            NoChange
-
-    let transform_expression = topdown transform_node
-
-end
-
-(*********************************************************************************************************************
- * Switch Simplifier
- ********************************************************************************************************************)
-
-module SwitchSimplifier = struct
-
-    let substitute_vexpr result i = Substitute [ (result, i) ]
-
-    let substitute_int result i   = substitute_vexpr result (VEXPR_Integer i)
-
-    let transform_node _ = function
-        | EXPR_Switch (label, VEXPR_Integer sel, default_branch, branches) ->
-            begin try
-                Replace (List.nth branches sel)
-            with Failure "nth" ->
-                Replace default_branch
-            end
-
-        | _ ->
-            NoChange
-
-
-    let transform_expression = topdown transform_node
-
-end
-
-(*********************************************************************************************************************
- * Constant folding
- ********************************************************************************************************************)
-
-let topdown_transformations = 
-    [ ArithmeticSimplifier.transform_node
-    ; BitwiseArithmeticSimplifier.transform_node
-    ; SwitchSimplifier.transform_node
-    ]
-
-let transform = topdowns topdown_transformations 
-
-

File source/Languages/Lang_CWCPS/Transformation/EtaConversionTransformation.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-
-(*********************************************************************************************************************
- * Unused definitions
- ********************************************************************************************************************)
-
-module EtaReduction = struct
-
-    let transform_definition sb (deflabel, defname, defargs, inexpr) =
-        let expected_args = List.map (fun v -> VEXPR_Variable v) defargs in
-        match inexpr with
-            | EXPR_App (_, (VEXPR_Variable _ as fname'), actual_args)
-            | EXPR_App (_, (VEXPR_TopContinuation _ as fname'), actual_args) 
-              when expected_args = actual_args ->
-                (defname, fname') :: sb
-
-            | _ -> 
-                sb
-
-    let transform_node _ = function
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            let sb = List.fold_left transform_definition [] definitions in
-            Substitute sb
-
-        | _ ->
-            NoChange
-
-end
-
-(*********************************************************************************************************************
- * 
- ********************************************************************************************************************)
-
-let topdown_transformations = 
-    [ EtaReduction.transform_node
-    ]
-
-let transform = topdowns
-        topdown_transformations 
-

File source/Languages/Lang_CWCPS/Transformation/Hoisting.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-open Analysis.VariableUsageAnalysis
-
-(*********************************************************************************************************************
- * Unused definitions
- ********************************************************************************************************************)
-
-module MovingFix = struct
-
-    let collect_nested_fix = function
-        | EXPR_Fix (label, ((_::_) as definitions), in_expr) ->
-            (definitions, in_expr)
-
-        | EXPR_Fix (_, [], expr)
-        | expr ->
-            ([], expr)
-
-
-    let rebuild_fix in_expr defs cont = match defs with
-        | None ->
-            cont in_expr
-
-        | Some (label, definitions) ->
-            EXPR_Fix (label, definitions, cont in_expr)
-
-    let merge_defOpts a b = match a,b with
-        | None, Some _ -> b
-        | Some _, None -> a
-        | Some (l, a), Some (_, b) -> Some (l, a@b)
-        | None, None -> None
-
-    let handle_definition (def_label, def_name, def_args, def_body) aux =
-        let (sub_definitions, new_body) = collect_nested_fix def_body in
-        let new_definition = (def_label, def_name, def_args, new_body) in
-        (new_definition :: sub_definitions @ aux)
-
-    let handle_definitions definitions =
-        List.fold_right handle_definition definitions []
-
-    let remove_nested_fix = function 
-        | EXPR_Fix (label, definitions, in_expr) when definitions <> [] ->
-            (Some (label, handle_definitions definitions), in_expr)
-
-        | EXPR_Fix (_, [], _) as expr 
-        | expr ->
-            (None, expr)
-
-    let transformation enumerators = function
-        | EXPR_Fix (reclabel, definitions, 
-            EXPR_Fix (_, sub_definitions, in_expr)) ->
-
-            let new_definitions = handle_definitions (definitions @ sub_definitions) in
-            let new_fix         = EXPR_Fix (reclabel, new_definitions, in_expr) in
-            Replace new_fix
-
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            Replace (EXPR_Fix (reclabel, handle_definitions definitions, in_expr))
-
-        | EXPR_ConditionPrimOp(label, primop, arg1, arg2, then_branch, else_branch) ->
-            let (then_defOpt, then_expr) = remove_nested_fix then_branch in
-            let (else_defOpt, else_expr) = remove_nested_fix else_branch in
-            let defOpt = merge_defOpts then_defOpt else_defOpt in
-            let new_fix = rebuild_fix (then_expr, else_expr) defOpt (fun (then_expr, else_expr) ->
-                EXPR_ConditionPrimOp(label, primop, arg1, arg2, then_expr, else_expr)
-                ) in
-            Replace new_fix
-
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            let (defOpt, new_in_expr) = remove_nested_fix in_expr in
-            let new_fix = rebuild_fix new_in_expr defOpt (fun expr ->
-                EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, expr) 
-                ) in
-            Replace new_fix
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            let (defOpt, new_in_expr) = remove_nested_fix in_expr in
-            let new_fix = rebuild_fix new_in_expr defOpt (fun expr ->
-                EXPR_Record (label, fields, result, expr)
-                ) in
-            Replace new_fix
-
-
-        | _ ->
-            NoChange
-end
-
-(*********************************************************************************************************************
- * 
- ********************************************************************************************************************)
-
-let bottomup_transformations = 
-    [ MovingFix.transformation
-    ; MovingFix.transformation
-    ]
-
-let transform = bottomups
-    bottomup_transformations 
-

File source/Languages/Lang_CWCPS/Transformation/NaiveClosureConversion.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open Batteries
-open AST
-open Analysis.VariableUsageAnalysis
-open TransformationFramework
-open Lang_Common.Enumerators
-
-module ClosureRepresentation = struct
-
-    let mapping fvs = VariableSet.to_list fvs 
-
-end
-
-module UnpackTransformation = struct
-
-    let rec insert_selection enumerators cl_var expr offset = function
-        | [] ->
-            expr
-
-        | packed_var::packed_vars ->
-            let node_label = LabelEnumerator.get_next enumerators.label_enumerator in
-            let new_var    = VariableEnumerator.get_next enumerators.variable_enumerator in
-            let new_expr   = subst [ (packed_var, VEXPR_Variable new_var) ] expr in
-            let rest       = insert_selection enumerators cl_var new_expr (succ offset) packed_vars in
-            EXPR_Select (node_label, offset, cl_var, new_var, rest)
-
-    let transform (cl_var, mapping) enumerators e = insert_selection enumerators cl_var e 1 mapping
-
-end
-
-let get_varname = function
-    | Variable (Identifier x) -> x
-
-module PackTransformation = struct
-
-    let make_closure_record func args =
-        List.map (fun arg -> (VEXPR_Variable arg, OFFp 0)) (func::args)
-
-    let transform_generate_closure mapping enumerators value var cont =
-        let cl_var       = VariableEnumerator.get_next enumerators.variable_enumerator ~suffix:"cl" in
-        let node_label   = LabelEnumerator.get_next enumerators.label_enumerator in
-        let fields       = make_closure_record var mapping in
-        EXPR_Record (node_label, fields, cl_var, cont (VEXPR_Variable cl_var))
-
-    let transform_value_expression mappings enumerators value cont =
-            match value with
-                | VEXPR_Variable var ->
-                    begin try
-                        let (_, mapping) = VariableMap.find var mappings in
-                        transform_generate_closure mapping enumerators value var cont
-                    with 
-                        | Not_found ->
-                            cont value
-                    end
-                | _ ->
-                    cont value
-
-    let rec transform_value_expression_list mappings enumerators values cont = 
-        match values with
-            | [] ->
-                cont []
-
-            | x::xs ->
-                let cont' ys =
-                    transform_value_expression mappings enumerators x (fun y -> cont (y::ys))
-                    in
-                transform_value_expression_list mappings enumerators xs cont'
-
-
-    let transform_application mappings enumerators label func args =
-        transform_value_expression mappings enumerators func (fun func' ->
-            transform_value_expression_list mappings enumerators args (fun args'' ->
-                    EXPR_App (label, func', args'')
-            )
-        )
-
-
-    let transform_field mappings enumerators (value, access_path) cont =
-        transform_value_expression mappings enumerators value (fun value' -> cont (value', access_path))
-
-
-    let rec transform_fields mappings enumerators fields cont =
-        match fields with
-            | [] ->
-                cont []
-
-            | x::xs ->
-                let cont' ys =
-                    transform_field mappings enumerators x (fun y -> cont (y::ys))
-                    in
-                transform_fields mappings enumerators xs cont'
-
-    let transform_record mappings enumerators label fields result in_expr =
-        transform_fields mappings enumerators fields (fun fields' ->
-            EXPR_Record (label, fields', result, in_expr)
-            )
-
-    let transform_node mappings enumerators = function
-        | EXPR_App (label, func, args) ->
-            Replace (transform_application mappings enumerators label func args)
-
-        | EXPR_Record (label, fields, result, in_expr) ->
-            Replace (transform_record mappings enumerators label fields result in_expr)
-
-        | _ ->
-            NoChange
-
-    let transform data = topdown (transform_node data)
-
-end
-
-module ClosureCallTransformation = struct
-
-    let handle_called_closure topclo cl enumerators label args =
-        match cl with
-        | VEXPR_Variable clvar ->
-            let func_ptr    = VariableEnumerator.get_next enumerators.variable_enumerator ~suffix:"fptr" in
-            let node_label  = LabelEnumerator.get_next enumerators.label_enumerator in
-            let cont        = EXPR_App (label, VEXPR_Variable func_ptr, cl::args) in
-            EXPR_Select (node_label, 0, cl, func_ptr, cont)
-
-        | VEXPR_TopContinuation ->
-            EXPR_App (label, topclo, args)
-
-        | _ ->
-            EXPR_App (label, cl, args)
-
-    let handle_arg topclo = function
-        | VEXPR_TopContinuation ->
-            topclo
-
-        | vexpr ->
-            vexpr
-
-    let transform_node topclo enumerators = function
-        | EXPR_App (label, func, args) ->
-            Replace (handle_called_closure topclo func enumerators label (List.map (handle_arg topclo) args))
-        | _ ->
-            NoChange
-
-    let transform enumerators expr =
-        let topclo     = VariableEnumerator.get_next enumerators.variable_enumerator ~suffix:"topclo" in
-        let node_label = LabelEnumerator.get_next enumerators.label_enumerator in
-
-        let main = bottomup (transform_node (VEXPR_Variable topclo)) enumerators expr in
-        EXPR_Record (node_label, [ ( VEXPR_TopContinuation, OFFp 0) ], topclo, main)
-
-end
-
-module Transformation = struct
-
-
-    let make_mapping enumerators result (def_label, def_name, def_args, def_body) = 
-        let cl_var   = VariableEnumerator.get_next enumerators.variable_enumerator ~suffix:"cl" in
-        let fvs      = VariableSet.diff_list (free_variables_of_expression def_body) (def_name::def_args) in
-        let item     = VariableMap.add def_name (cl_var, ClosureRepresentation.mapping fvs) result in
-        item
-
-    let pack_definition enumerators mappings ((def_label, def_name, def_args, def_body) as def) =
-        try
-            let (cl_var, mapping) = VariableMap.find def_name mappings in
-            let pack_data         = mappings in
-            let new_body          = PackTransformation.transform pack_data enumerators def_body in
-            (def_label, def_name, cl_var::def_args, new_body) 
-        with 
-            | Not_found ->
-                def (* TODO: internal error *)
-
-    let unpack_definition enumerators mappings ((def_label, def_name, def_args, def_body) as def) =
-        try
-            let (cl_var, mapping) = VariableMap.find def_name mappings in
-            let unpack_data       = (VEXPR_Variable cl_var, mapping) in
-            let new_body          = UnpackTransformation.transform unpack_data enumerators def_body in
-            (def_label, def_name, def_args, new_body) 
-        with 
-            | Not_found ->
-                print_endline "not_found";
-                def (* TODO: internal error *)
-
-    let transform_node enumerators = function
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            let mappings             = List.fold_left (make_mapping enumerators) VariableMap.empty definitions in
-
-            let packed_definitions   = List.map (pack_definition enumerators mappings) definitions in
-            let unpacked_definitions = List.map (unpack_definition enumerators mappings) packed_definitions in
-
-            let new_definitions      = unpacked_definitions in
-            let new_in_expr          = PackTransformation.transform mappings enumerators in_expr in
-            Replace (EXPR_Fix (reclabel, new_definitions, new_in_expr))
-
-        | _ ->
-            NoChange
-
-    let transform = topdown transform_node
-end
-
-
-let transform enumerators ast =
-    let ast = Transformation.transform enumerators ast in
-    let ast = ClosureCallTransformation.transform enumerators ast in
-    ast

File source/Languages/Lang_CWCPS/Transformation/RecordUsageOptimization.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-
-(*********************************************************************************************************************
- * Fetching Reducer
- ********************************************************************************************************************)
-
-module FetchingReducer = struct
-    open Analysis.VariableUsageAnalysis.BoundByAnalysis
-
-
-    let optim_select result offset = function
-        | BoundBy_Record(label, fields) ->
-            begin try
-                match List.at fields offset with
-                | (value, OFFp 0) ->
-                    Substitute [ (result, value) ]
-
-                | _ ->
-                    NoChange
-
-            with _ ->
-                NoChange
-            end
-
-        | _ ->
-            NoChange
-
-
-    let transform_node enumerators f_bby = function
-        | EXPR_Select (label, offset, VEXPR_Variable rname, result, in_expr) ->
-            Option.map_default (optim_select result offset) NoChange (f_bby rname)
-
-        | EXPR_Offset (label, 0, value, result, in_expr) ->
-            Substitute [ (result, value) ]
-
-        | _ ->
-            NoChange
-
-end
-
-(*********************************************************************************************************************
- * RecordDefinition
- ********************************************************************************************************************)
-
-module RecordAccessPathOptimization = struct
-    open Analysis.VariableUsageAnalysis.BoundByAnalysis
-
-    let transform_access_path access_path = function
-        | BoundBy_Select (label, offset, fromval) ->
-            Some (fromval, SELp (offset, access_path))
-
-        | _ ->
-            None
-
-    let transform_field f_bby = function
-        | (VEXPR_Variable vname, access_path) as p ->
-            let t = Option.bind (f_bby vname) (transform_access_path access_path) in
-            Option.default p t
-
-        | p -> p
-
-    let transform_node enumerators f_bby = function
-        | EXPR_Record (label, fields, result, in_expr) ->
-            let new_fields = List.map (transform_field f_bby) fields in
-            if fields = new_fields
-            then NoChange
-            else Replace (EXPR_Record (label, new_fields, result, in_expr))
-
-        | _ ->
-            NoChange
-
-end
-
-(*********************************************************************************************************************
- * Constant folding
- ********************************************************************************************************************)
-
-let bottomup_transformations = 
-    [ FetchingReducer.transform_node
-    ; RecordAccessPathOptimization.transform_node
-    ]
-
-let transform = bottomups_with_analysis
-    Analysis.VariableUsageAnalysis.BoundByAnalysis.analyze
-    bottomup_transformations
-

File source/Languages/Lang_CWCPS/Transformation/RegisterSpilling.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-open Analysis.VariableUsageAnalysis
-
-(*********************************************************************************************************************
- * Unused definitions
- ********************************************************************************************************************)
-
-module Transformation = struct
-
-    let transform_node enumerators = function
-        | expr ->
-            NoChange
-
-end
-
-let transform = topdown
-    Transformation.transform_node

File source/Languages/Lang_CWCPS/Transformation/RemoveDeadCodeOptimization.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-
-(*********************************************************************************************************************
- * Unused definitions
- ********************************************************************************************************************)
-
-module UnusedDefinitions = struct
-
-    let substitute_vexpr result i = Substitute [ (result, i) ]
-
-    let substitute_int result i   = substitute_vexpr result (VEXPR_Integer i)
-
-    let is_var_used usage_count var = usage_count var > 0
-
-    let try_remove_definition usage_count var in_expr =
-        if is_var_used usage_count var
-        then NoChange 
-        else Replace in_expr
-
-    let transform_node enumerators usage_count = function
-
-        (* optimalize unused fixs *)
-
-        | EXPR_Fix (reclabel, [], in_expr) ->
-            Replace in_expr
-
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            let definitions' = List.filter (is_var_used usage_count  % get_name_from_fixdef) definitions in
-            begin match definitions' with
-            | [] ->
-                Replace in_expr
-
-            | _ ->
-                if List.length definitions = List.length definitions'
-                then NoChange
-                else Replace (EXPR_Fix (reclabel, definitions', in_expr))
-            end
-
-        (* unused result of arithmetic operations *)
-
-        | EXPR_ArithmeticBinaryPrimOp (_, _, _, _, result, in_expr) 
-        | EXPR_ArithmeticUnaryPrimOp (_, _, _, result, in_expr) 
-        | EXPR_Select(_, _, _, result, in_expr)
-        | EXPR_Offset(_, _, _, result, in_expr)
-        | EXPR_Record(_, _, result, in_expr) ->
-            try_remove_definition usage_count result in_expr 
-
-            
-        | _ ->
-            NoChange
-end
-
-(*********************************************************************************************************************
- * 
- ********************************************************************************************************************)
-
-let bottomup_transformations = 
-    [ UnusedDefinitions.transform_node
-    ]
-
-let transform = bottomups_with_analysis
-        Analysis.VariableUsageAnalysis.UsageCountingAnalysis.analyze
-        bottomup_transformations 
-

File source/Languages/Lang_CWCPS/Transformation/UncurryFunctionsTransformation.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open AST
-open TransformationFramework
-open Batteries
-open Lang_Common.Enumerators
-
-(*********************************************************************************************************************
- * Fetching Reducer
- ********************************************************************************************************************)
-
-module UncurryFunctions = struct
-    open Analysis.VariableUsageAnalysis.BoundByAnalysis
-
-    (*
-     * let
-     *      fix f x1 ... xn c = 
-     *          let
-     *              fix g y1 ... yn = body in
-     *              and <<nested_defs>>
-     *              in
-     *          g c
-     *      and <<defs>>
-     * in program
-     *
-     * is transformed into
-     *
-     * let
-     *      fix f x1 ... xn c =
-     *          let fix g y1 ... yn = f' x1 ... xn c g y1 ... yn in
-     *          c g
-     *
-     *      and f' x1 ... xn c g y1 ... yn =
-     *          let fix <<nested_defs>> in
-     *          body
-     *      and <<defs>>
-     *
-     * in program
-     *)
-
-    let construct_forwarder variable_enumerator f f_args g g_args c =
-(*
-        let f_args' = List.map (fun _ -> get_next_variable_from_enumerator variable_enumerator) f_args in
-        let g_args' = List.map (fun _ -> get_next_variable_from_enumerator variable_enumerator) g_args in
-        let f'      = get_next_variable_from_enumerator variable_enumerator in
-        let g'      = get_next_variable_from_enumerator variable_enumerator in
-
-        let definition_of_g' =
-            ( get_new_label ()
-            , g'
-            , g_args'
-            , EXPR_App (get_new_label (), VEXPR_Variable f', 
-                        List.map (fun s -> VEXPR_Variable s) (f_args' @ [g'] @ g_args'))
-            ) in
-*)
-
-        raise Exit
-    let uncurry_definition variable_enumerator = function
-        | (definition_label, definition_name, definition_formal_arguments,
-                EXPR_Fix (subreclabel, nested_definitions,
-                    EXPR_App (app_label, VEXPR_Variable called_function, [VEXPR_Variable passed_function])))
-          when List.mem called_function definition_formal_arguments ->
-
-            begin try
-
-                let is_definition_of_called_function (_, name, _, _) = name = passed_function in
-
-                let (_, _, passed_function_formal_arguments, passed_function_body) =
-                    List.find is_definition_of_called_function nested_definitions
-                    in
-
-                let forwarder = construct_forwarder variable_enumerator
-                    definition_name definition_formal_arguments
-                    passed_function passed_function_formal_arguments
-                    called_function
-                    in
-
-                [forwarder]
-            with Not_found ->
-                []
-            end
-
-        | def ->
-            [def]
-
-    let construct_fix label definitions in_expr new_definitions = 
-        if definitions = new_definitions
-        then NoChange
-        else Replace (EXPR_Fix(label, new_definitions, in_expr))
-
-    let transform_node variable_enumerator = function
-        | EXPR_Fix(reclabel, definitions, in_expr) ->
-            definitions
-            |> List.map (uncurry_definition variable_enumerator)
-            |> List.concat
-            |> construct_fix reclabel definitions in_expr
-
-        | _ ->
-            NoChange
-
-end
-
-(*********************************************************************************************************************
- * Constant folding
- ********************************************************************************************************************)
-
-let topdown_transformations = 
-    [ UncurryFunctions.transform_node
-    ]
-
-(*
-let transform = 
-    topdowns_with_dummy_variable_enumerator topdown_transformations
-*)

File source/Languages/Lang_CWCPS_Analysis.mlpack

+CallGraphOfKnownFunctions
+ClosureNeediness
+SizeSavingAnalysis
+VariableUsageAnalysis

File source/Languages/Lang_CWCPS_Analysis/CallGraphOfKnownFunctions.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open AST
+open AnalysisFramework
+open Batteries
+open Lib_Algebra.Monoid
+open DataModuleTypes
+
+(*********************************************************************************************************************
+ * Types
+ ********************************************************************************************************************)
+
+type node
+    = Start
+    | Variable of variable
+
+type graph = (node, node) Hashtbl.t
+
+(*********************************************************************************************************************
+ * Implementation
+ ********************************************************************************************************************)
+
+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
+
+(*********************************************************************************************************************
+ * Entry point
+ ********************************************************************************************************************)
+
+let analyze program =
+    let graph       = Graph.create () in
+    let is_escaping = VariableUsageAnalysis.EscapingVariablesAnalysis.analyze program in
+    let is_known    = is_escaping %> not in
+    analyze_expression is_known Start graph program;
+    graph
+

File source/Languages/Lang_CWCPS_Analysis/ClosureNeediness.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+open Lib_Algebra.Monoid
+open AST
+
+(*
+ * very unmature
+ *)
+
+(*********************************************************************************************************************
+ * Implementation
+ ********************************************************************************************************************)
+
+(*
+module MakeMachineDependentAnalysis
+    (ArchitectureSpecification : module type of Architecture_Specification) = struct
+
+    module VariableSetMonoid = SetMonoid(VariableOrderedType)
+    module VariableSetMonoidUtils = MonoidUtils(VariableSetMonoid)
+
+    module WorklistAlgorithm = Lib_Algebra.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 trans      = transform (program, bby) in
+        let first      = CWCPS_CallGraphOfKnownFunctions.Start in
+        WorklistAlgorithm.Core.compute trans call_graph first
+
+end
+
+(*********************************************************************************************************************
+ * Machine specialization
+ ********************************************************************************************************************)
+
+module X86_Version = MakeMachineDependentAnalysis(Architecture_X86_Specification)
+
+*)

File source/Languages/Lang_CWCPS_Analysis/SizeSavingAnalysis.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open AST
+open AnalysisFramework
+open Batteries
+open Lib_Algebra.Monoid
+open DataModuleTypes
+
+(**
+ 
+ References:
+     A.Appel ,,Compiling with continuations''
+ *)
+
+(*********************************************************************************************************************
+ * Constants
+ ********************************************************************************************************************)
+
+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
+
+(*********************************************************************************************************************
+ * Data
+ ********************************************************************************************************************)
+
+module IntMonoid = PreparedMonoids.IntSumMonoid
+
+(*********************************************************************************************************************
+ * Implementation
+ ********************************************************************************************************************)
+
+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
+            ]