type exp = Int of int | Add of exp * exp | Sub of exp * exp | Mul of exp * exp | Div of exp * exp | Bool of bool | Zero of exp | Equal of exp * exp | Cond of exp * exp * exp | One | Shi of exp | Lam of exp | App of exp * exp | Fix of exp exception Unreachable type value = ValInt of int | ValBool of bool | ValFun of exp * environ and environ = value list let eval(exp) = let rec ev = function (Int i, _) -> ValInt i | (Add (exp1, exp2), env) -> let ValInt i1 = ev(exp1, env) and ValInt i2 = ev(exp2, env) in ValInt (i1 + i2) | (Sub (exp1, exp2), env) -> let ValInt i1 = ev(exp1, env) and ValInt i2 = ev(exp2, env) in ValInt (i1 - i2) | (Mul (exp1, exp2), env) -> let ValInt i1 = ev(exp1, env) and ValInt i2 = ev(exp2, env) in ValInt (i1 * i2) | (Div (exp1, exp2), env) -> let ValInt i1 = ev(exp1, env) and ValInt i2 = ev(exp2, env) in ValInt (i1 / i2) | (Bool b, _) -> ValBool b | (Zero exp, env) -> let ValInt i = ev(exp, env) in ValBool (i = 0) | (Cond (exp, exp1, exp2), env) -> let ValBool b = ev(exp, env) in if b then ev(exp1, env) else ev(exp2, env) | (Equal(exp1, exp2), env) -> let ValInt i1 = ev(exp1, env) and ValInt i2 = ev(exp2, env) in ValBool (i1 = i2) | (One, v :: _) -> v | (Shi(exp), _ :: env) -> ev(exp, env) | (Lam _ as f, env) -> ValFun(f, env) | (App(exp1, exp2), env) -> let fexp = ev(exp1, env) and farg = ev(exp2, env) in let ValFun(f, env) = fexp in begin match f with Lam body -> ev(body, farg :: env) | Fix (Lam body) -> ev(body, farg :: fexp :: env) end | (Fix f as exp, env) -> ValFun(f, ValFun(exp, env) :: env) | _ -> raise Unreachable (* this can be safely eliminated *) in ev(exp, []) let eval_safe exp = let rec ev = function (Int i, _) -> (Obj.magic i: value) | (Add (exp1, exp2), env) -> let i1 = (Obj.magic(ev(exp1, env)): int) and i2 = (Obj.magic(ev(exp2, env)): int) in (Obj.magic(i1 + i2): value) | (Sub (exp1, exp2), env) -> let i1 = (Obj.magic(ev(exp1, env)): int) and i2 = (Obj.magic(ev(exp2, env)): int) in (Obj.magic(i1 - i2): value) | (Mul (exp1, exp2), env) -> let i1 = (Obj.magic(ev(exp1, env)): int) and i2 = (Obj.magic(ev(exp2, env)): int) in (Obj.magic(i1 * i2): value) | (Div (exp1, exp2), env) -> let i1 = (Obj.magic(ev(exp1, env)): int) and i2 = (Obj.magic(ev(exp2, env)): int) in (Obj.magic(i1 / i2): value) | (Bool b, _) -> (Obj.magic b: value) | (Zero exp, env) -> let i = (Obj.magic(ev(exp, env)): int) in (Obj.magic (i = 0): value) | (Cond (exp, exp1, exp2), env) -> let b = (Obj.magic(ev(exp, env)): bool) in if b then ev(exp1, env) else ev(exp2, env) | (Equal(exp1, exp2), env) -> let i1 = (Obj.magic(ev(exp1, env)): int) and i2 = (Obj.magic(ev(exp2, env)): int) in (Obj.magic (i1 = i2): value) | (One, v :: _) -> v | (Shi(exp), _ :: env) -> ev(exp, env) | (Lam _ as f, env) -> (Obj.magic(f, env): value) | (App(exp1, exp2), env) -> let fexp = ev(exp1, env) and farg = ev(exp2, env) in let (f, env) = (Obj.magic fexp: exp * environ) in begin match f with Lam body -> ev(body, farg :: env) | Fix (Lam body) -> ev(body, farg :: fexp :: env) | _ -> raise Unreachable (* this can be safely eliminated *) end | (Fix f as exp, env) -> (Obj.magic(f, (Obj.magic(exp, env): value) :: env): value) | _ -> raise Unreachable (* this can be safely eliminated *) in ev(exp, []) let test times code arg = let start = Sys.time () in let _ = for i = 1 to times do code arg done in let finish = Sys.time () in let sys_time = finish -. start in Printf.printf ("The sys time is %f.\n") sys_time let fact = Fix(Lam(Cond(Zero(One), Int 1, Mul(One, App(Shi(One), Sub(One, Int 1)))))) let fib = Fix(Lam(Cond(Equal(One, Int 1), Int 1, Cond(Equal(One, Int 2), Int 1, Add(App(Shi(One), Sub(One, Int 1)), App(Shi(One), Sub(One, Int 2))))))) let test times code arg = let start = Sys.time () in let _ = for i = 1 to times do code arg done in let finish = Sys.time () in let sys_time = finish -. start in Printf.printf ("The sys time is %f.\n") sys_time let compare n code code' arg = let rec aux code code' sum sum' n = if n = 0 then (sum, sum') else let ct_st = Sys.time () in let _ = code(arg) in let ct_fi = Sys.time () in let ct_st' = Sys.time () in let _ = code'(arg) in let ct_fi' = Sys.time () in aux code code' (sum +. ct_fi -. ct_st) (sum' +. ct_fi' -. ct_st') (n-1) in let (sum1, sum1') = aux code code' 0.0 0.0 n in let (sum2', sum2) = aux code' code 0.0 0.0 n in (sum1 +. sum2, sum1' +. sum2') let fib = Fix(Lam(Cond(Equal(One, Int 1), Int 1, Cond(Equal(One, Int 2), Int 1, Add(App(Shi(One), Sub(One, Int 1)), App(Shi(One), Sub(One, Int 2))))))) let experiment () = let _ = let (t, t_safe) = compare 5 eval eval_safe (App(fib, Int 30)) in Printf.printf ("t = %f / t_safe = %f\n") t t_safe and _ = let (t_safe, t) = compare 5 eval_safe eval (App(fib, Int 30)) in Printf.printf ("t = %f / t_safe = %f\n") t t_safe in () ;;