Commits

Paweł Wieczorek  committed 9162811 Merge

merge

  • Participants
  • Parent commits ebc1a58, 851ff17

Comments (0)

Files changed (35)

 _build
 _build_top
 .initfile
+Reference.docdir
 *.swp
 *.swo
 SRCS_ALL=${SRCS1} ${PARSERS} ${LEXERS} ${SRCS2}
 VERBOSE?=@
 
-.PHONY: clean ${PROGRAM}
+.PHONY: clean ${PROGRAM} doc
 .SUFFIXES: .cma
 
 all: ${PROGRAM}
 
-ob:
+doc:
+	./tools/enumerate_modules > doc/Reference.odocl
+	${VERBOSE}${OCAMLBUILD} ${OCAMLLIBS} ${OCAMLDIRS} doc/Reference.docdir/index.html
 
 ${PROGRAM}: src/Autogen.ml
 	${VERBOSE}${OCAMLBUILD} ${OCAMLLIBS} ${OCAMLDIRS} src/${PROGRAM}.native
-<**/*>: package(batteries), package(stringpainter), thread
+<**/*>: package(batteries), package(stringpainter), oUnit, thread

File doc/Reference.odocl

+Algebra_Lattice
+Algebra_Monoid
+AST
+Autogen
+Command
+CWCPS_Analysis
+CWCPS_AST
+CWCPS_BetaContractionOptimization
+CWCPS_ConditionalJumpsOptimization
+CWCPS_ConstantFoldingOptimization
+CWCPS_EtaConversionTransformation
+CWCPS_Eval
+CWCPS_PrettyPrinter
+CWCPS_RecordUsageOptimization
+CWCPS_RemoveDeadCodeOptimization
+CWCPS_Transformation
+CWCPS_UncurryFunctionsTransformation
+CWCPS_Util
+CWCPS_VariableUsageAnalysis
+DataModuleTypes
+Enumerators
+Environment
+Error
+Errors
+Formatter
+Language_drivers
+Main
+MiniML_AST
+MiniML_Eval
+MiniML_PrettyPrinter
+MiniML_to_CWCPS
+MiniML_TypeChecker
+MiniML_Util
+Opifex
+Predefined
+RestrictedHashtbl
+Store
+Tty
+Util
+While_AST
+While_Eval
+While_PrettyPrinter

File src/Analysis/CWCPS/CWCPS_VariableUsageAnalysis.ml

  *)
 
 open CWCPS_AST
-open CWCPS_Transformation
+open CWCPS_Analysis
 open Batteries
 open Algebra_Monoid
 open DataModuleTypes
         |> List.filter_map get_variable
         |> FunMonoid.from_arg_list_with_val 1
 
-    let __analyze = function
+    let analyze_node = function
         | EXPR_App (label, fun_val, arg_vals) ->
             fun_val::arg_vals
             |> handle_values
             |> handle_values
 
     let analyze tm =
-        let module M = MonoidBased(FunMonoid) in
-        M.Gather.gather __analyze tm
+        let module M = MonoidBasedAnalysis(FunMonoid) in
+        M.Gather.gather analyze_node tm
         |> FunMonoid.call
 
 end
         |> List.filter_map get_variable
         |> FunMonoid.from_arg_list_with_val true
 
-    let __analyze = function
+    let analyze_node = function
         | EXPR_App (label, fun_val, arg_vals) ->
             arg_vals
             |> handle_values
             FunMonoid.neutral
 
     let analyze =
-        let module M = MonoidBased(FunMonoid) in
-        M.Gather.gather __analyze
+        let module M = MonoidBasedAnalysis(FunMonoid) in
+        M.Gather.gather analyze_node
 
 end
 
 
     module Type = struct
 
-        type t =
-            BoundBy_FixDef of label * variable list * expression
+        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
 
         |> List.map (fun (a,b) -> (a, Some b))
         |> FunMonoid.from_list
 
-    let __analyze = function
+    let analyze_node = function
         | EXPR_Fix (reclabel, definitions, in_expr) ->
             let f (deflabel, defname, defargs, defbody) =
                 (defname, BoundBy_FixDef (deflabel, defargs, defbody))
             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 tm = 
-        let module M = MonoidBased(FunMonoid) in
-        M.Gather.gather __analyze tm
-        |> FunMonoid.call
+    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
 
             (EscapingVariablesAnalysis.FunMonoid)
             (BoundByAnalysis.FunMonoid)
 
-    let __analyze = Monoid.combine
-        UsageCountingAnalysis.__analyze
-        EscapingVariablesAnalysis.__analyze
-        BoundByAnalysis.__analyze
+    let analyze_node = Monoid.combine
+        UsageCountingAnalysis.analyze_node
+        EscapingVariablesAnalysis.analyze_node
+        BoundByAnalysis.analyze_node
 
     let analyze tm =
-        let module M = MonoidBased(Monoid) in
-        let (mon_usage_count, mon_escapes, mon_bound_by) = M.Gather.gather __analyze tm in
+        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
+        ; bound_by      = BoundByAnalysis.FunMonoid.call            mon_bound_by
         }
 
 end

File src/Language/CWCPS/CWCPS_AST.ml

  * Abstract Syntax Tree
  ************************************************************************************************)
 
-type type_expression
-    = TP_Int
-    | TP_Bool
-    | TP_Unit
-    | TP_Fun of type_expression * type_expression
-    | TP_Ref of type_expression
-    | TP_Variable of type_variable
-
-type type_scheme
-    = TS_Type of type_expression
-    | TS_Product of type_variable * type_scheme
-
 type arithmetic_binary_primitive_operation
     = PRIMOP_Add
     | PRIMOP_Sub

File src/Language/CWCPS/CWCPS_Analysis.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open Algebra_Monoid
+open Batteries
+
+(*************************************************************************************************
+ * Lattice based 
+ ************************************************************************************************)
+
+module MonoidBasedAnalysis (M : Monoid) = struct
+
+    module MH = MonoidUtils (M)
+
+    module Gather = struct
+
+        let gather_from_subexpr f = function
+            | EXPR_App (label, fun_val, arg_vals) ->
+                M.neutral
+
+            | EXPR_Switch (label, sel_val, default_branch, branches) ->
+                MH.oper_map f (default_branch::branches)
+
+            | EXPR_Fix (reclabel, definitions, in_expr) ->
+                let f' (deflabel, defname, defargs, defexpr) = f defexpr in
+                MH.opers [f in_expr; MH.oper_map f' definitions]
+
+            | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
+                f in_expr
+
+            | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
+                f in_expr
+
+            | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
+                MH.oper_map f [then_branch; else_branch]
+
+            | EXPR_Offset (label, offset, arg, result, in_expr)
+            | EXPR_Select (label, offset, arg, result, in_expr) ->
+                f in_expr
+
+            | EXPR_Record (label, fields, result, in_expr) ->
+                f in_expr
+
+
+        let rec gather f tm =
+            MH.opers [f tm; gather_from_subexpr (gather f) tm]
+
+    end
+
+    module GatherDep = struct
+
+        let gather_dep_from_subexpr f data = function
+            | EXPR_App (label, fun_val, arg_vals) ->
+                data
+
+            | EXPR_Switch (label, sel_val, default_branch, branches) ->
+                MH.oper_fold f data (default_branch::branches)
+
+            | EXPR_Fix (reclabel, definitions, in_expr) ->
+                let f' (deflabel, defname, defargs, defexpr) = defexpr in
+                List.map f' definitions
+                |> MH.oper_fold f data
+
+            | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
+                f data in_expr
+
+            | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
+                f data in_expr
+
+            | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
+                MH.oper_fold f data [then_branch; else_branch]
+
+            | EXPR_Offset (label, offset, arg, result, in_expr)
+            | EXPR_Select (label, offset, arg, result, in_expr) ->
+                f data in_expr
+
+            | EXPR_Record (label, fields, result, in_expr) ->
+                f data in_expr
+
+        let rec gather_topdown_ f data tm =
+            gather_dep_from_subexpr (gather_topdown_ f) (f data tm) tm
+
+        let rec gather_bottomup_ f data tm =
+            f (gather_dep_from_subexpr (gather_bottomup_ f) data tm) tm
+
+        let topdown f  = gather_topdown_ f M.neutral
+
+        let bottomup f = gather_bottomup_ f M.neutral
+
+    end
+
+end

File src/Language/CWCPS/CWCPS_PrettyPrinter.ml

         psp_group
         [ psp_keyword "switch"
         ; show_value_expression selval
-        ; psp_indent_group
+        ; psp_break
+        ; psp_group
             (BatList.mapi f branches)
-        ; psp_indent_group
+        ; psp_group
             [ psp_operator "|"
             ; psp_syntax "_"
             ; psp_operator "->"
             ; show_expression default_branch
             ]
+        ; psp_break
+        ; psp_keyword "end"
+        ; psp_break
         ]
 
     | EXPR_Select (label, offset, value, result, in_expr) -> psp_group

File src/Language/CWCPS/CWCPS_Transformation.ml

 open Algebra_Monoid
 open Batteries
 
-(*************************************************************************************************
- * Lattice based 
- ************************************************************************************************)
-
-module MonoidBased (M : Monoid) = struct
-
-    module MH = MonoidUtils (M)
-
-    module Gather = struct
-
-        let gather_from_subexpr f = function
-            | EXPR_App (label, fun_val, arg_vals) ->
-                M.neutral
-
-            | EXPR_Switch (label, sel_val, default_branch, branches) ->
-                MH.oper_map f (default_branch::branches)
-
-            | EXPR_Fix (reclabel, definitions, in_expr) ->
-                let f' (deflabel, defname, defargs, defexpr) = f defexpr in
-                MH.opers [f in_expr; MH.oper_map f' definitions]
-
-            | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-                f in_expr
-
-            | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-                f in_expr
-
-            | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-                MH.oper_map f [then_branch; else_branch]
-
-            | EXPR_Offset (label, offset, arg, result, in_expr)
-            | EXPR_Select (label, offset, arg, result, in_expr) ->
-                f in_expr
-
-            | EXPR_Record (label, fields, result, in_expr) ->
-                f in_expr
-
-
-        let rec gather f tm =
-            MH.opers [f tm; gather_from_subexpr (gather f) tm]
-
-    end
-
-    module GatherDep = struct
-
-        let gather_dep_from_subexpr f data = function
-            | EXPR_App (label, fun_val, arg_vals) ->
-                data
-
-            | EXPR_Switch (label, sel_val, default_branch, branches) ->
-                MH.oper_fold f data (default_branch::branches)
-
-            | EXPR_Fix (reclabel, definitions, in_expr) ->
-                let f' (deflabel, defname, defargs, defexpr) = defexpr in
-                List.map f' definitions
-                |> MH.oper_fold f data
-
-            | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-                f data in_expr
-
-            | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-                f data in_expr
-
-            | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-                MH.oper_fold f data [then_branch; else_branch]
-
-            | EXPR_Offset (label, offset, arg, result, in_expr)
-            | EXPR_Select (label, offset, arg, result, in_expr) ->
-                f data in_expr
-
-            | EXPR_Record (label, fields, result, in_expr) ->
-                f data in_expr
-
-        let rec gather_topdown_ f data tm =
-            gather_dep_from_subexpr (gather_topdown_ f) (f data tm) tm
-
-        let rec gather_bottomup_ f data tm =
-            f (gather_dep_from_subexpr (gather_bottomup_ f) data tm) tm
-
-        let topdown f  = gather_topdown_ f M.neutral
-
-        let bottomup f = gather_bottomup_ f M.neutral
-
-    end
-
-end
 
 (*************************************************************************************************
  * Transformation
  ************************************************************************************************)
 
-module Transformation = struct
+type transformation_result
+    = NoChange
+    | Substitute of (variable * value_expression) list
+    | Replace of expression
 
-    type transformation_result
-        = NoChange
-        | Substitute of (variable * value_expression) list
-        | Replace of expression
+let apply_on_subexpr f = function
+    | EXPR_App (label, fun_val, arg_vals) as tm ->
+        tm
 
-    let apply_on_subexpr f = function
-        | EXPR_App (label, fun_val, arg_vals) as tm ->
+    | EXPR_Switch (label, sel_val, default_branch, branches) ->
+        EXPR_Switch (label, sel_val, f default_branch, List.map f branches)
+
+    | EXPR_Fix (reclabel, definitions, in_expr) ->
+        let f' (deflabel, defname, defargs, defexpr) = (deflabel, defname, defargs, f defexpr) in
+        EXPR_Fix (reclabel, List.map f' definitions, f in_expr)
+
+    | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
+        EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, f in_expr)  
+
+    | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
+        EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, f in_expr)
+
+    | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
+        EXPR_ConditionPrimOp (label, primop, arg1, arg2, f then_branch, f else_branch) 
+
+    | EXPR_Offset (label, offset, arg, result, in_expr) ->
+        EXPR_Offset (label, offset, arg, result, f in_expr)
+
+    | EXPR_Select (label, offset, arg, result, in_expr) ->
+        EXPR_Select (label, offset, arg, result, f in_expr)
+
+    | EXPR_Record (label, fields, result, in_expr) ->
+        EXPR_Record (label, fields, result, f in_expr)
+
+let rec apply_transforms fs tm = 
+    match fs with
+        | [] ->
             tm
+        | f::fs ->
+            match f tm with
+                | NoChange ->
+                    apply_transforms fs tm
+                | Substitute sb' ->
+                    let s = (subst sb' ) in
+                    apply_transforms fs (apply_on_subexpr s tm)
+                | Replace tm' ->
+                    apply_transforms fs tm'
 
-        | EXPR_Switch (label, sel_val, default_branch, branches) ->
-            EXPR_Switch (label, sel_val, f default_branch, List.map f branches)
+let rec topdowns fs tm =
+    apply_on_subexpr (topdowns fs) (apply_transforms fs tm)
 
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            let f' (deflabel, defname, defargs, defexpr) = (deflabel, defname, defargs, f defexpr) in
-            EXPR_Fix (reclabel, List.map f' definitions, f in_expr)
+let rec bottomups fs tm =
+    apply_transforms fs (apply_on_subexpr (bottomups fs) tm)
 
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, f in_expr)  
+let topdown f tm = topdowns [f] tm
 
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, in_expr) ->
-            EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, f in_expr)
+let bottomup f tm = bottomups [f] tm
 
-        | EXPR_ConditionPrimOp (label, primop, arg1, arg2, then_branch, else_branch) ->
-            EXPR_ConditionPrimOp (label, primop, arg1, arg2, f then_branch, f else_branch) 
+(**)
 
-        | EXPR_Offset (label, offset, arg, result, in_expr) ->
-            EXPR_Offset (label, offset, arg, result, f in_expr)
+let transforms_with_parameter transforms p fs tm =
+    let fs'    = List.map (Util.revapply p) fs in
+    transforms fs' tm
 
-        | EXPR_Select (label, offset, arg, result, in_expr) ->
-            EXPR_Select (label, offset, arg, result, f in_expr)
+let transforms_with_function transforms g fs tm =
+    let result = g tm in
+    transforms_with_parameter transforms result fs tm
 
-        | EXPR_Record (label, fields, result, in_expr) ->
-            EXPR_Record (label, fields, result, f in_expr)
+(**)
 
-    let rec apply_transforms fs tm = 
-        match fs with
-            | [] ->
-                tm
-            | f::fs ->
-                match f tm with
-                    | NoChange ->
-                        apply_transforms fs tm
-                    | Substitute sb' ->
-                        let s = (subst sb' ) in
-                        apply_transforms fs (apply_on_subexpr s tm)
-                    | Replace tm' ->
-                        apply_transforms fs tm'
+let topdowns_with_analysis analize fs tm =
+    transforms_with_function topdowns analize fs tm
 
-    let rec topdowns fs tm =
-        apply_on_subexpr (topdowns fs) (apply_transforms fs tm)
+let bottomups_with_analysis analize fs tm =
+    transforms_with_function bottomups analize fs tm
 
-    let rec bottomups fs tm =
-        apply_transforms fs (apply_on_subexpr (bottomups fs) tm)
+(**)
 
-    let topdown f tm = topdowns [f] tm
+let transforms_with_dummy_variable_enumerator transforms fs tm =
+    let enumerator = Enumerators.make_variable_enumerator ~prefix:"_dummy" 0 in
+    transforms_with_parameter transforms enumerator fs tm
 
-    let bottomup f tm = bottomups [f] tm
+(**)
 
+let topdowns_with_dummy_variable_enumerator =
+    transforms_with_dummy_variable_enumerator topdowns
 
-    (**)
-
-    let topdowns_with_analysis analize fs tm =
-        let result = analize tm in
-        let fs'    = List.map (Util.revapply result) fs in
-        topdowns fs' tm 
-
-    let bottomups_with_analysis analize fs tm =
-        let result = analize tm in
-        let fs'    = List.map (Util.revapply result) fs in
-        bottomups fs' tm 
-end
-

File src/Language/Common/Enumerators.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open Batteries
+open AST
+
+(*************************************************************************************************
+ * Blackbox
+ ************************************************************************************************)
+
+type variable_enumerator = variable BatEnum.t
+type label_enumerator    = label BatEnum.t
+
+(*************************************************************************************************
+ * Enum
+ ************************************************************************************************)
+
+let base_sequence start = 
+    Enum.seq start succ ((=) max_int) 
+
+let base_prefixed_sequence prefix start = 
+    base_sequence start
+    |> Enum.map (fun n -> prefix ^ string_of_int n)
+
+let make_variable_enumerator ?(prefix = "_var") start : variable_enumerator = 
+    base_prefixed_sequence prefix start
+    |> Enum.map (fun x -> Identifier x)
+    |> Enum.map (fun x -> Variable x)
+
+let make_label_enumerator start : label_enumerator =
+    base_sequence start
+    |> Enum.map (fun x -> Label x)
+
+let get_next_variable_from_enumerator (t : variable_enumerator) = 
+    match Enum.get t with
+    | None   -> failwith "Impossible, the variable enumerator exhausted?"
+    | Some x -> x
+
+let get_next_label_from_enumerator (t : label_enumerator) =
+    match Enum.get t with
+    | None   -> failwith "Impossible, the label enumerator exhausted?"
+    | Some x -> x

File src/Language/Common/Enumerators.mli

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+type variable_enumerator
+type label_enumerator
+
+val make_variable_enumerator : ?prefix:string -> int -> variable_enumerator
+
+val make_label_enumerator : int -> label_enumerator
+
+val get_next_variable_from_enumerator : variable_enumerator -> AST.variable
+
+val get_next_label_from_enumerator : label_enumerator -> AST.label

File src/Language/Language_drivers.ml

 
         type value = While_Eval.value
 
-        type result = unit
+        type evaluation_result = unit
 
         type typecheck_result = unit
 
     let eval store ast =
         While_Eval.eval_program store (While_Eval.standard_io_driver) ast
 
-    let print_result () = ()
+    let print_evaluation_result () = ()
 
     let print_typecheck_result _ = ()
 
 
         type value = MiniML_Eval.value
 
-        type result = MiniML_Eval.environment * MiniML_Eval.value
+        type evaluation_result = MiniML_Eval.environment * MiniML_Eval.value
 
         type typecheck_result = MiniML_AST.type_expression Environment.t  * MiniML_AST.type_expression
     end
     let eval store ast = 
         MiniML_Eval.eval_program store (IODriver.standard_io_driver) ast
 
-    let print_result (env, mval) =
+    let print_evaluation_result (env, mval) =
             let print_env = Formatter.print_painters -| ValuePrinter.show_environment in
             let print_val = Formatter.print_painters -| show_value in
             print_val mval;
 
         type value = CWCPS_Eval.value 
 
-        type result = CWCPS_Eval.value list
+        type evaluation_result = CWCPS_Eval.value list
 
-        type typecheck_result = CWCPS_AST.type_expression Environment.t 
+        type typecheck_result = ()
 
     end
 
 
     let show_value = ValuePrinter.show_value
 
-    let print_result = Formatter.print_painter_nl -|
+    let print_evaluation_result = Formatter.print_painter_nl -|
         Formatter.psp_list_map
             Formatter.psp_square_bracket
             (Formatter.psp_operator ";")

File src/Lib/Command.ml

 module type Language_representation = sig
     type ast
 
-    type result
+    type evaluation_result
 
     type value
 
 
     val pretty_print : ast -> unit
 
-    val eval : value Store.t -> ast -> result
+    val eval : value Store.t -> ast -> evaluation_result
 
     val show_value : value -> Formatter.painter list
 
-    val print_result : result -> unit
+    val print_evaluation_result : evaluation_result -> unit
 
     val typecheck : ast -> typecheck_result
 
             let output = Formatter.render_painter (Formatter.psp_group doc) in
             print_newline ();
             Util.print_words_ln [ "-"; "result:" ];
-            LD.print_result result;
+            LD.print_evaluation_result result;
             Util.print_words_ln [ "-"; "memory:" ];
             print_endline output;
             0
 open Command
 open Batteries
 open MiniML_to_CWCPS
-open CWCPS_ConstantFolding
-open CWCPS_RemoveDeadCode
-open CWCPS_BetaContraction
-open CWCPS_EtaReduction
+open CWCPS_ConstantFoldingOptimization
+open CWCPS_RemoveDeadCodeOptimization
+open CWCPS_BetaContractionOptimization
+open CWCPS_EtaConversionTransformation
+open CWCPS_ConditionalJumpsOptimization
+open CWCPS_RecordUsageOptimization
+open CWCPS_UncurryFunctionsTransformation
 open Algebra_Monoid
+open Enumerators
 
 (************************************************************************************************
  * About command
             Util.print_words_ln [ "-"; "result" ];
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform ConstantFolding" ];
-            let res = CWCPS_ConstantFolding.topdown res in
+            let res = CWCPS_ConstantFoldingOptimization.transform res in
+            CWCPS_driver.pretty_expr res;
+            Util.print_words_ln [ "-"; "transform ConditionalJumpOptimization" ];
+            let res = CWCPS_ConditionalJumpsOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform BetaContraction" ];
-            let res = CWCPS_BetaContraction.bottomup res in
+            let res = CWCPS_BetaContractionOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
-            let res = CWCPS_BetaContraction.bottomup res in
+            let res = CWCPS_BetaContractionOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
-            let res = CWCPS_BetaContraction.bottomup res in
+            let res = CWCPS_BetaContractionOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
-            let res = CWCPS_BetaContraction.bottomup res in
+            let res = CWCPS_BetaContractionOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform ConstantFolding" ];
-            let res = CWCPS_ConstantFolding.topdown res in
+            let res = CWCPS_ConstantFoldingOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform EtaReduction" ];
-            let res = CWCPS_EtaReduction.topdown res in
+            let res = CWCPS_EtaConversionTransformation.transform res in
             CWCPS_driver.pretty_expr res;
             Util.print_words_ln [ "-"; "transform RemoveDeadCode" ];
-            let res = CWCPS_RemoveDeadCode.bottomup res in
+            let res = CWCPS_RemoveDeadCodeOptimization.transform res in
             CWCPS_driver.pretty_expr res;
             ()
         with

File src/Transformation/CWCPS/CWCPS_BetaContraction.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open CWCPS_AST
-open CWCPS_Transformation
-open Batteries
-open CWCPS_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
-            Transformation.Replace (subst sb body)
-            
-        | _ ->
-            Transformation.NoChange
-
-    let transformation 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
-
-        | _ ->
-            Transformation.NoChange
-end
-
-(*************************************************************************************************
- * 
- ************************************************************************************************)
-
-let bottomup_transformations = 
-    [ BetaContraction.transformation
-    ]
-
-let bottomup =
-    Transformation.bottomups_with_analysis
-        CWCPS_VariableUsageAnalysis.analyze
-        bottomup_transformations 
-

File src/Transformation/CWCPS/CWCPS_BetaContractionOptimization.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+open Batteries
+open CWCPS_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 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
+    CWCPS_VariableUsageAnalysis.analyze
+    bottomup_transformations 
+

File src/Transformation/CWCPS/CWCPS_ConditionalJumpsOptimization.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+open Batteries
+
+(*************************************************************************************************
+ * Arithmetic Simplifier
+ ************************************************************************************************)
+
+(* TODO: use usage-counting to check if inlined function is dedicated for our jump *)
+module ArithmeticSimplifier = struct
+    open CWCPS_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 check_called_function (f_bby fname1)
+
+        | _ ->
+            None
+            
+
+    let transform_node 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
+    CWCPS_VariableUsageAnalysis.BoundByAnalysis.analyze
+    bottomup_transformations
+

File src/Transformation/CWCPS/CWCPS_ConstantFolding.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open CWCPS_AST
-open CWCPS_Transformation
-open Batteries
-
-(*************************************************************************************************
- * Arithmetic Simplifier
- ************************************************************************************************)
-
-module ArithmeticSimplifier = struct
-
-    let substitute_vexpr result i = Transformation.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 *)
-
-        | _ ->
-            Transformation.NoChange
-
-    let transformation = function
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            transform_binary (primop, arg1, arg2, result)
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, branch) ->
-            Transformation.NoChange
-
-        | _ ->
-            Transformation.NoChange
-
-
-    let topdown_transformation = Transformation.topdown transformation
-
-end
-
-(*************************************************************************************************
- * Bitwise Arithmetic Simplifier
- ************************************************************************************************)
-
-module BitwiseArithmeticSimplifier = struct
-
-    let substitute_vexpr result i = Transformation.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 *)
-
-        | _ ->
-            Transformation.NoChange
-
-    let transformation = function
-        | EXPR_ArithmeticBinaryPrimOp (label, primop, arg1, arg2, result, in_expr) ->
-            transform_binary (primop, arg1, arg2, result)
-
-        | EXPR_ArithmeticUnaryPrimOp (label, primop, arg, result, branch) ->
-            Transformation.NoChange
-
-        | _ ->
-            Transformation.NoChange
-
-
-    let topdown_transformation = Transformation.topdown transformation
-
-end
-
-(*************************************************************************************************
- * Bitwise Arithmetic Simplifier
- ************************************************************************************************)
-
-module ConditionSimplifier = struct
-
-    let substitute_vexpr result i = Transformation.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 Transformation.Replace then_branch
-            else Transformation.Replace else_branch
-
-        | _ ->
-            Transformation.NoChange
-
-    let transformation = function
-        | EXPR_ConditionPrimOp (label, primop, val1, val2, then_branch, else_branch) ->
-            transform_condition (primop, val1, val2, then_branch, else_branch)
-
-        | _ ->
-            Transformation.NoChange
-
-    let topdown_transformation = Transformation.topdown transformation
-
-end
-
-(*************************************************************************************************
- * Switch Simplifier
- ************************************************************************************************)
-
-module SwitchSimplifier = struct
-
-    let substitute_vexpr result i = Transformation.Substitute [ (result, i) ]
-
-    let substitute_int result i   = substitute_vexpr result (VEXPR_Integer i)
-
-    let transformation = function
-        | EXPR_Switch (label, VEXPR_Integer sel, default_branch, branches) ->
-            begin try
-                Transformation.Replace (List.nth branches sel)
-            with Failure "nth" ->
-                Transformation.Replace default_branch
-            end
-
-        | _ ->
-            Transformation.NoChange
-
-
-    let topdown_transformation = Transformation.topdown transformation
-
-end
-
-(*************************************************************************************************
- * Constant folding
- ************************************************************************************************)
-
-let topdown_transformations = 
-    [ ArithmeticSimplifier.transformation
-    ; BitwiseArithmeticSimplifier.transformation
-    ; SwitchSimplifier.transformation
-    ]
-
-let topdown = Transformation.topdowns topdown_transformations 
-
-

File src/Transformation/CWCPS/CWCPS_ConstantFoldingOptimization.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+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 src/Transformation/CWCPS/CWCPS_EtaConversionTransformation.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+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 src/Transformation/CWCPS/CWCPS_EtaReduction.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open CWCPS_AST
-open CWCPS_Transformation
-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 fname as fname'), actual_args)
-              when expected_args = actual_args ->
-                (defname, fname') :: sb
-
-            | _ -> 
-                sb
-
-    let transformation = function
-        | EXPR_Fix (reclabel, definitions, in_expr) ->
-            let sb = List.fold_left transform_definition [] definitions in
-            Transformation.Substitute sb
-
-        | _ ->
-            Transformation.NoChange
-
-end
-
-(*************************************************************************************************
- * 
- ************************************************************************************************)
-
-let topdown_transformations = 
-    [ EtaReduction.transformation
-    ]
-
-let topdown =
-    Transformation.topdowns
-        topdown_transformations 
-

File src/Transformation/CWCPS/CWCPS_RecordUsageOptimization.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+open Batteries
+
+(*************************************************************************************************
+ * Fetching Reducer
+ ************************************************************************************************)
+
+module FetchingReducer = struct
+    open CWCPS_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 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 CWCPS_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 (transform_access_path access_path) (f_bby vname) in
+            Option.default p t
+
+        | p -> p
+
+    let transform_node 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
+    CWCPS_VariableUsageAnalysis.BoundByAnalysis.analyze
+    bottomup_transformations
+

File src/Transformation/CWCPS/CWCPS_RemoveDeadCode.ml

-(*
- * Opifex
- *
- * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
- *)
-
-open CWCPS_AST
-open CWCPS_Transformation
-open Batteries
-
-(*************************************************************************************************
- * Unused definitions
- ************************************************************************************************)
-
-module UnusedDefinitions = struct
-
-    let substitute_vexpr result i = Transformation.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 Transformation.NoChange 
-        else Transformation.Replace in_expr
-
-    let transformation usage_count = function
-
-        (* optimalize unused fixs *)
-
-        | EXPR_Fix (reclabel, [], in_expr) ->
-            Transformation.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
-            | [] ->
-                Transformation.Replace in_expr
-
-            | _ ->
-                if List.length definitions = List.length definitions'
-                then Transformation.NoChange
-                else Transformation.Replace (EXPR_Fix (reclabel, definitions', in_expr))
-            end
-
-        (* unused result of arithmetic operations *)
-
-        | EXPR_ArithmeticBinaryPrimOp (_, _, _, _, result, in_expr) 
-        | EXPR_ArithmeticUnaryPrimOp (_, _, _, result, in_expr) ->
-            try_remove_definition usage_count result in_expr 
-
-            
-        | _ ->
-            Transformation.NoChange
-end
-
-(*************************************************************************************************
- * 
- ************************************************************************************************)
-
-let bottomup_transformations = 
-    [ UnusedDefinitions.transformation
-    ]
-
-let bottomup =
-    Transformation.bottomups_with_analysis
-        CWCPS_VariableUsageAnalysis.UsageCountingAnalysis.analyze
-        bottomup_transformations 
-

File src/Transformation/CWCPS/CWCPS_RemoveDeadCodeOptimization.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+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 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
+        CWCPS_VariableUsageAnalysis.UsageCountingAnalysis.analyze
+        bottomup_transformations 
+

File src/Transformation/CWCPS/CWCPS_UncurryFunctionsTransformation.ml

+(*
+ * Opifex
+ *
+ * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+open CWCPS_AST
+open CWCPS_Transformation
+open Batteries
+open Enumerators
+
+(*************************************************************************************************
+ * Fetching Reducer
+ ************************************************************************************************)
+
+module UncurryFunctions = struct
+    open CWCPS_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
+    ]
+