Commits

Paweł Wieczorek  committed bb892f1

refactored CWCPS evaluator

  • Participants
  • Parent commits 2088d73

Comments (0)

Files changed (1)

File src/Language/CWCPS/CWCPS_Eval.ml

 open CWCPS_AST
 open Batteries
 
-(*************************************************************************************************
+(*********************************************************************************************************************
  * Value 
- ************************************************************************************************)
+ ********************************************************************************************************************)
 
 type value
     = VAL_Integer of int
 
 and environment   = value Environment.t
 
-(*************************************************************************************************
+(*********************************************************************************************************************
  * Basic definitions
- ************************************************************************************************)
+ ********************************************************************************************************************)
 
 type input_func = unit -> value
 type output_func = value -> unit
 let io_read (_, _, io_driver)         = fst io_driver ()
 let io_write (_, _, io_driver)  value = snd io_driver value
 
-(*************************************************************************************************
+(*********************************************************************************************************************
  * Exceptions
- ************************************************************************************************)
+ ********************************************************************************************************************)
 
 exception Unknown_variable of variable
 exception Unknown_store_location of Store.location
 exception Invalid_closure
 exception Throwed_exception of identifier * context
 
-(*************************************************************************************************
- * Context
- ************************************************************************************************)
-
-module Context = struct
-
-    (*-------------------------------------------------------------------------------------------
-     * Representation
-     *)
-
-    type store         = value Store.t
-
-    type context       = environment * store * input_output_driver
-
-    let get_environment_from_context (environment, _, _) = environment
-
-    let get_store_from_context (_, store, _) = store
-
-
-    (*-------------------------------------------------------------------------------------------
-     * Store
-     *)
-
-    let get_value_from_store context variable =
-        try
-            let store = get_store_from_context context in
-            Store.fetch_location store variable
-        with
-            Not_found -> raise (Unknown_store_location variable)
-
-    let put_value_to_store context location value =
-            let store = get_store_from_context context in
-            Store.store_location store location value
-
-    let get_new_location context =
-        let store = get_store_from_context context in
-        Store.alloc_location store
-
-    (*-------------------------------------------------------------------------------------------
-     * Environment
-     *)
-
-    let get_value_from_environment context variable = 
-        try
-            let environment = get_environment_from_context context in
-            Environment.get environment variable
-        with
-            Not_found -> raise (Unknown_variable variable)
-
-
-    let with_extended_environment context variable value continuation =
-        let environment = get_environment_from_context context in
-        Environment.with_extended_environment environment variable value continuation
-
-    let with_extended_environment_m context _xs continuation =
-        let environment = get_environment_from_context context in
-        Environment.with_extended_environment_m environment _xs continuation
-
-    (*-------------------------------------------------------------------------------------------
-     * Cloning
-     *)
-
-    let get_environment_clone (environment, _, _) =
-        Environment.clone environment
-
-    let make_context_from_environment (_, store, io_driver) environment : context =
-        (environment, store, io_driver)
-
-    let make_environmental_clone_of_context context =
-        let new_environment = get_environment_clone context in
-        make_context_from_environment context new_environment
-
-end
-
-
-(*************************************************************************************************
+(*********************************************************************************************************************
  * The evaluator
- ************************************************************************************************)
-
-let eval_value_expression context = function
-    | VEXPR_Integer i ->
-        VAL_Integer i
-
-    | VEXPR_Unit ->
-        VAL_Unit
-
-    | VEXPR_TopContinuation ->
-        VAL_TopContinuation
-
-    | VEXPR_Variable v ->
-        Context.get_value_from_environment context v
+ ********************************************************************************************************************)
 
 let rec resolve_access_path = function
     | value, OFFp 0 ->
     | VAL_TopContinuation -> true
     | _ -> false
 
-(*************************************************************************************************
- * The evaluator
- ************************************************************************************************)
+(*********************************************************************************************************************
+ * Parameters for the Evaluator
+ ********************************************************************************************************************)
 
-let rec eval_program store io_driver = function
-    | expression ->
-        let environment = Environment.create () in
-        let context     = (environment, store, io_driver) in
-        eval_expression context expression
+module type Parameters = sig
 
-and eval_expression context = function
-    | EXPR_App (_, function_vexpr, actual_arguments) ->
-        let function_value = eval_value_expression context function_vexpr in
-        if is_kexit function_value
-        then begin
-            List.map (eval_value_expression context) actual_arguments
-        end else begin
-            let (formal_arguments, body_expression, closure_environment) = force_closure function_value in
-            let new_context = Context.make_context_from_environment context closure_environment in
-            let cont () = eval_expression new_context body_expression in
+    val store : store
 
-            let evaluated_arguments = List.map (eval_value_expression context) actual_arguments in
-            let vs = List.combine formal_arguments evaluated_arguments in
-            Context.with_extended_environment_m new_context vs cont
-        end
+    val environment : environment ref
 
-    | EXPR_Fix (_, definitions, inexpression) ->
-        let environment = Context.get_environment_clone context in
-        let handle_def aux (_, variable, argument_variables, expression) =
-            let value   = VAL_Closure (argument_variables, expression, environment) in
-            Environment.put environment variable value;
-            (variable, value) :: aux
-            in
+end
 
-        let cont () = eval_expression context inexpression in
-        let bindings = List.fold_left handle_def [] definitions in
-        Context.with_extended_environment_m context bindings cont
+(*********************************************************************************************************************
+ * Utils
+ ********************************************************************************************************************)
 
-    | EXPR_ArithmeticBinaryPrimOp (label, primop, val1, val2, var, branch) ->
-        let value1 = force_integer (eval_value_expression context val1) in
-        let value2 = force_integer (eval_value_expression context val2) in
-        let func   = eval_arithmetic_binary_primitive_operation primop in
-        let result = VAL_Integer (func value1 value2) in
-        let cont () = eval_expression context branch in
-        Context.with_extended_environment context var result cont
+module MakeUtils(Parameters : Parameters) = struct
 
-    | EXPR_ArithmeticUnaryPrimOp (label, primop, vale, var, branch) ->
-        let value  = force_integer (eval_value_expression context vale) in
-        let func   = eval_arithmetic_unary_primitive_operation primop in
-        let result = VAL_Integer (func value) in
-        let cont () = eval_expression context branch in
-        Context.with_extended_environment context var result cont
+    include Parameters
 
-    | EXPR_ConditionPrimOp (label, primop, val1, val2, branch1, branch2) ->
-        let value1 = force_integer (eval_value_expression context val1) in
-        let value2 = force_integer (eval_value_expression context val2) in
-        let func   = eval_condition_primitive_operation primop in
-        let result = func value1 value2 in
-        if result
-            then eval_expression context branch1
-            else eval_expression context branch2
+    (*----------------------------------------------------------------------------------------------------------------
+     * Store
+     *)
 
-    | EXPR_Switch (label, selval, default_branch, branches) ->
-        let value = force_integer (eval_value_expression context selval) in
-        begin try
-            let branch = List.nth branches value in
-            eval_expression context branch
-        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
+    let get_value_from_store variable =
+        try
+            Store.fetch_location store variable
+        with
+            Not_found -> raise (Unknown_store_location variable)
 
-    | 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
+    let put_value_to_store location value =
+            Store.store_location store location value
 
-    | 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
+    let get_new_location () =
+        Store.alloc_location store
 
-(*************************************************************************************************
- * Additional helpers (should be moved out from mutual-recursive block)
- ************************************************************************************************)
+    (*----------------------------------------------------------------------------------------------------------------
+     * Environment
+     *)
 
-and force_integer = function
-    | VAL_Integer value ->
-        value
+    let get_value_from_environment variable = 
+        try
+            Environment.get !environment variable
+        with
+            Not_found -> raise (Unknown_variable variable)
 
-    | _ ->
-        raise Invalid_integer
 
-and force_closure = function
-    | VAL_Closure (arguments, body_expression, closure_environment) ->
-        (arguments, body_expression, closure_environment)
+    let with_extended_environment variable value continuation =
+        Environment.with_extended_environment !environment variable value continuation
 
-    | _ ->
-        raise Invalid_closure
+    let with_extended_environment_m _xs continuation =
+        Environment.with_extended_environment_m !environment _xs continuation
 
+    (*----------------------------------------------------------------------------------------------------------------
+     * Cloning
+     *)
+
+    let get_environment_clone () =
+        Environment.clone !environment
+
+    let change_environment env =
+        environment := env
+end
+
+(*********************************************************************************************************************
+ * The implementation
+ ********************************************************************************************************************)
+
+module Implementation(Parameters : Parameters) = struct
+
+    module Utils = MakeUtils(Parameters)
+
+    let eval_value_expression = function
+        | VEXPR_Integer i ->
+            VAL_Integer i
+
+        | VEXPR_Unit ->
+            VAL_Unit
+
+        | VEXPR_TopContinuation ->
+            VAL_TopContinuation
+
+        | VEXPR_Variable v ->
+            Utils.get_value_from_environment v
+
+    let rec eval_program = function
+        | expression ->
+            eval_expression expression
+
+    and eval_expression = function
+        | EXPR_App (_, function_vexpr, actual_arguments) ->
+            let function_value = eval_value_expression function_vexpr in
+            if is_kexit function_value
+            then begin
+                List.map eval_value_expression actual_arguments
+            end else begin
+                let (formal_arguments, body_expression, closure_environment) = force_closure function_value in
+                Utils.change_environment closure_environment;
+                let cont () = eval_expression body_expression in
+
+                let evaluated_arguments = List.map eval_value_expression actual_arguments in
+                let vs = List.combine formal_arguments evaluated_arguments in
+                Utils.with_extended_environment_m vs cont
+            end
+
+        | EXPR_Fix (_, definitions, inexpression) ->
+            let environment = Utils.get_environment_clone () in
+            let handle_def (_, variable, argument_variables, expression) =
+                (* TODO: each closure should have own clone of environment !!!!! *)
+                let value   = VAL_Closure (argument_variables, expression, environment) in
+                Environment.put environment variable value;
+                (variable, value) 
+                in
+
+            let cont () = eval_expression inexpression in
+            let bindings = List.map handle_def definitions in
+            Utils.with_extended_environment_m bindings cont
+
+        | EXPR_ArithmeticBinaryPrimOp (label, primop, val1, val2, var, branch) ->
+            let value1 = force_integer (eval_value_expression val1) in
+            let value2 = force_integer (eval_value_expression val2) in
+            let func   = eval_arithmetic_binary_primitive_operation primop in
+            let result = VAL_Integer (func value1 value2) in
+            let cont () = eval_expression branch in
+            Utils.with_extended_environment var result cont
+
+        | EXPR_ArithmeticUnaryPrimOp (label, primop, vale, var, branch) ->
+            let value  = force_integer (eval_value_expression vale) in
+            let func   = eval_arithmetic_unary_primitive_operation primop in
+            let result = VAL_Integer (func value) in
+            let cont () = eval_expression branch in
+            Utils.with_extended_environment var result cont
+
+        | EXPR_ConditionPrimOp (label, primop, val1, val2, branch1, branch2) ->
+            let value1 = force_integer (eval_value_expression val1) in
+            let value2 = force_integer (eval_value_expression val2) in
+            let func   = eval_condition_primitive_operation primop in
+            let result = func value1 value2 in
+            if result
+                then eval_expression branch1
+                else eval_expression branch2
+
+        | EXPR_Switch (label, selval, default_branch, branches) ->
+            let value = force_integer (eval_value_expression selval) in
+            begin try
+                let branch = List.nth branches value in
+                eval_expression branch
+            with Failure "nth" ->
+                eval_expression default_branch
+            end
+           
+        | EXPR_Record (label, fields, result, in_expr) ->
+            let fields' = List.map (Tuple2.map1 (eval_value_expression )) fields in
+            let values  = List.map resolve_access_path fields' in
+            let vrecord = VAL_Record (values, 0) in
+            let cont () = eval_expression in_expr in
+            Utils.with_extended_environment result vrecord cont
+
+        | EXPR_Select (label, offset, value, result, in_expr) ->
+            let vrecord = eval_value_expression value in
+            let access  = SELp (offset, OFFp 0) in
+            let v       = resolve_access_path (vrecord, access) in
+            let cont () = eval_expression in_expr in
+            Utils.with_extended_environment result v cont
+
+        | EXPR_Offset (label, offset, value, result, in_expr) ->
+            let vrecord = eval_value_expression value in
+            let access  = OFFp offset in
+            let v       = resolve_access_path (vrecord, access) in
+            let cont () = eval_expression in_expr in
+            Utils.with_extended_environment result v cont
+
+    (*----------------------------------------------------------------------------------------------------------------
+     * TODO: move out 
+     *)
+
+    and force_integer = function
+        | VAL_Integer value ->
+            value
+
+        | _ ->
+            raise Invalid_integer
+
+    and force_closure = function
+        | VAL_Closure (arguments, body_expression, closure_environment) ->
+            (arguments, body_expression, closure_environment)
+
+        | _ ->
+            raise Invalid_closure
+
+end
+
+(*********************************************************************************************************************
+ * Entry point
+ ********************************************************************************************************************)
+
+(* arguments only for compatibility with old interface *)
+let eval_program store io_driver =
+    let module Utils : Parameters = 
+        struct
+            let environment = ref (Environment.create ())
+            let store       = store
+        end in
+    let module M = Implementation(Utils) in
+    M.eval_program 
+