Commits

Paweł Wieczorek committed cccd9f0

tuples

Comments (0)

Files changed (6)

src/Analysis/CWCPS/CWCPS_VariableUsageAnalysis.ml

             [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 = MonoidBased(FunMonoid) in
         M.Gather.gather __analyze tm

src/Language/CWCPS/CWCPS_AST.ml

     | VEXPR_Unit
     | VEXPR_Variable of variable
 
+type access_path
+    = OFFp of int
+    | SELp of int * access_path
+
+type record_field = value_expression * access_path
+
 type expression
     = EXPR_App
         of label * value_expression * value_expression list
     | EXPR_Switch
         of label * value_expression * expression * expression list
 
+    | EXPR_Record
+        of label * record_field list * variable * expression
+
+    | EXPR_Offset
+        of label * int * value_expression * variable * expression
+
+    | EXPR_Select
+        of label * int * value_expression * variable * expression
+
 type declaration
     = DECL_Fix of label * (label * variable * variable list * expression) list
 
     | EXPR_ArithmeticUnaryPrimOp (label, _, _, _, _) -> label
     | EXPR_ConditionPrimOp (label, _, _, _, _, _) -> label
     | EXPR_Switch (label, _, _, _) -> label
+    | EXPR_Offset (label, _, _, _, _) -> label
+    | EXPR_Select (label, _, _, _, _) -> label
+    | EXPR_Record (label, _, _, _) -> label
 
 let get_label_from_declaration = function
     | DECL_Fix (label, declarations)  -> label
             let else_branch' = expr__subst else_branch in
             EXPR_ConditionPrimOp (label, primop, arg1', arg2', then_branch', else_branch')
 
+        | EXPR_Offset (label, offset, value, result, in_expr) ->
+            let value'      = vexpr__subst value in
+            let in_expr'    = Util.until0 (result = from_var) expr__subst in_expr in
+            EXPR_Offset (label, offset, value', result, in_expr')
+
+        | EXPR_Select (label, offset, value, result, in_expr) ->
+            let value'      = vexpr__subst value in
+            let in_expr'    = Util.until0 (result = from_var) expr__subst in_expr in
+            EXPR_Select (label, offset, value', result, in_expr')
+
+        | EXPR_Record (label, fields, result, in_expr) ->
+            let fields'     = List.map (Tuple2.map1 vexpr__subst) fields in
+            let in_expr'    = Util.until0 (result = from_var) expr__subst in_expr in
+            EXPR_Record (label, fields', result, in_expr')
+            
+
 let subst_vexpr xs expr =
     List.fold_right (uncurry subst_in_value_expression) xs expr
 
             let else_branch' = expr_renamer else_branch in
             EXPR_ConditionPrimOp (label, primop, arg1', arg2', then_branch', else_branch')
 
+        | EXPR_Select (label, offset, arg, result, in_expr) ->
+            let arg'         = vexpr_renamer arg in
+            let in_expr'     = expr_renamer in_expr in
+            EXPR_Select (label, offset, arg', result, in_expr')
+
+        | EXPR_Offset (label, offset, arg, result, in_expr) ->
+            let arg'         = vexpr_renamer arg in
+            let in_expr'     = expr_renamer in_expr in
+            EXPR_Offset (label, offset, arg', result, in_expr')
+
+        | EXPR_Record (label, fields, result, in_expr) ->
+            let fields'      = List.map (Tuple2.map1 vexpr_renamer) fields in
+            let in_expr'     = expr_renamer in_expr in
+            EXPR_Record (label, fields', result, in_expr')
+
+
 (*************************************************************************************************
  * Equality
  ************************************************************************************************)
             expr_equal (then_branch1, then_branch2) &&
             expr_equal (else_branch1, else_branch2)
 
+        | (EXPR_Select (_, offset1, arg1, result1, in_expr1),
+           EXPR_Select (_, offset2, arg2, result2, in_expr2)) ->
+
+            let cont () = expr_equal (in_expr1, in_expr2) in
+
+           offset1 = offset2 &&
+           vexpr_equal (arg1, arg2) &&
+           assume_eq result1 result2 cont
+
+        | (EXPR_Offset (_, offset1, arg1, result1, in_expr1),
+           EXPR_Offset (_, offset2, arg2, result2, in_expr2)) ->
+
+            let cont () = expr_equal (in_expr1, in_expr2) in
+
+           offset1 = offset2 &&
+           vexpr_equal (arg1, arg2) &&
+           assume_eq result1 result2 cont
+
+        | (EXPR_Record (_, fields1, result1, in_expr1),
+           EXPR_Record (_, fields2, result2, in_expr2)) ->
+
+           let cont () = expr_equal (in_expr1, in_expr2) in
+           List.for_all2 (fun (value1, _) (value2, _) -> vexpr_equal (value1, value2)) fields1 fields2 &&
+           assume_eq result1 result2 cont
+
         (*
          * I prefer this instead of "(_, _) -> false" because it allows compiler to generate
          * warning when I add new construction into the language
         | (EXPR_Fix _, _) 
         | (EXPR_ArithmeticBinaryPrimOp _, _)
         | (EXPR_ArithmeticUnaryPrimOp _, _)
-        | (EXPR_ConditionPrimOp _, _) ->
+        | (EXPR_ConditionPrimOp _, _)
+        | (EXPR_Record _, _)
+        | (EXPR_Select _, _)
+        | (EXPR_Offset _, _) ->
             false
 
         in

src/Language/CWCPS/CWCPS_Eval.ml

  *)
 
 open CWCPS_AST
+open Batteries
 
 (*************************************************************************************************
  * Value 
     = VAL_Integer of int
     | VAL_Unit
     | VAL_Closure of variable list * expression * environment
+    | VAL_Record of value list * int
 
 and environment   = value Environment.t
 
     | VEXPR_Variable v ->
         Context.get_value_from_environment context v
 
+let rec resolve_access_path = function
+    | value, OFFp 0 ->
+        value
+
+    | VAL_Record (elems, shift), OFFp offset ->
+        VAL_Record (elems, shift+offset)
+
+    | VAL_Record (elems, shift), SELp (offset, path) ->
+        resolve_access_path (List.nth elems (shift + offset), path)
+
+    | _ ->
+        failwith "Cannot resolve access path"
+
+
 (*************************************************************************************************
  * The evaluator
  ************************************************************************************************)
         with Failure "nth" ->
             eval_expression context default_branch
         end
+       
+    | EXPR_Record (label, fields, result, in_expr) ->
+        let fields' = List.map (Tuple2.map1 (eval_value_expression context)) fields in
+        let values  = List.map resolve_access_path fields' in
+        let vrecord = VAL_Record (values, 0) in
+        let cont () = eval_expression context in_expr in
+        Context.with_extended_environment context result vrecord cont
 
+    | EXPR_Select (label, offset, value, result, in_expr) ->
+        let vrecord = eval_value_expression context value in
+        let access  = SELp (offset, OFFp 0) in
+        let v       = resolve_access_path (vrecord, access) in
+        let cont () = eval_expression context in_expr in
+        Context.with_extended_environment context result v cont
+
+    | EXPR_Offset (label, offset, value, result, in_expr) ->
+        let vrecord = eval_value_expression context value in
+        let access  = OFFp offset in
+        let v       = resolve_access_path (vrecord, access) in
+        let cont () = eval_expression context in_expr in
+        Context.with_extended_environment context result v cont
 
 (*************************************************************************************************
  * Additional helpers (should be moved out from mutual-recursive block)

src/Language/CWCPS/CWCPS_PrettyPrinter.ml

             ]
         ]
 
+    | EXPR_Select (label, offset, value, result, in_expr) ->
+        [ Keyword "let"
+        ; Keyword "select"
+        ; Int offset
+        ; Keyword "from"
+        ; Nested (show_value_expression value)
+        ; Keyword "in"
+        ; Break
+        ; Nested (show_expression in_expr)
+        ]
+
+    | EXPR_Offset (label, offset, value, result, in_expr) ->
+        [ Keyword "let"
+        ; Keyword "offset"
+        ; Int offset
+        ; Keyword "from"
+        ; Nested (show_value_expression value)
+        ; Keyword "in"
+        ; Break
+        ; Nested (show_expression in_expr)
+        ]
+
+    | EXPR_Record (label, [], result, in_expr) ->
+        [ Keyword "let"
+        ; Keyword "record"
+        ; Syntax "("
+        ; Syntax ")"
+        ; Keyword "in"
+        ; Break
+        ; Nested (show_expression in_expr)
+        ]
+
+    | EXPR_Record (label, [vf1], result, in_expr) ->
+        [ Keyword "let"
+        ; Keyword "record"
+        ; Syntax "("
+        ; Nested (show_value_expression (fst vf1))
+        ; Syntax ")"
+        ; Keyword "in"
+        ; Break
+        ; Nested (show_expression in_expr)
+        ]
+
 (*------------------------------------------------------------------------------------------------
  * Pretty printer for declaration
  *)

src/Language/CWCPS/CWCPS_Transformation.ml

             | 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]
 
             | 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
 
         | 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

src/Language/CWCPS/CWCPS_Util.ml

     | VAL_Unit          -> [ Formatter.Value "()" ]
     | VAL_Closure (args,body,env) ->  _show_closure mem args body env
 
+
 and _show_value (ht, mpath) v =
     try