Skip to content

Instantly share code, notes, and snippets.

@EduardoRFS

EduardoRFS/my.dcps.changes.ml

Last active December 21, 2020 05:41
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save EduardoRFS/d500ea8e0aae646a833fb973b65cc551 to your computer and use it in GitHub Desktop.
Save EduardoRFS/d500ea8e0aae646a833fb973b65cc551 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
my.dcps.changes.ml
(* the test below was run using flambda + profile=release *)
(*
v: 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
v: 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
v: 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
v: 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
v: 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
Estimated testing time 50s (5 benchmarks x 10s). Change using '-quota'.
┌──────────┬──────────┬─────────┬──────────┬──────────┬────────────┐
│ Name │ Time/Run │ mWd/Run │ mjWd/Run │ Prom/Run │ Percentage │
├──────────┼──────────┼─────────┼──────────┼──────────┼────────────┤
│ dcps │ 5.72us │ 6.92kw │ 0.59w │ 0.59w │ 85.41% │
│ dcps' │ 6.27us │ 11.57kw │ 1.03w │ 1.03w │ 93.53% │
│ dcps'' │ 6.07us │ 12.87kw │ 1.23w │ 1.23w │ 90.56% │
│ dcps''' │ 6.67us │ 8.85kw │ 0.90w │ 0.90w │ 99.48% │
│ dcps'''' │ 6.70us │ 8.85kw │ 0.90w │ 0.90w │ 100.00% │
└──────────┴──────────┴─────────┴──────────┴──────────┴────────────┘
*)
type z = Z.t
let io_counter = ref 0
let io : z -> unit Lwt.t = fun _ -> incr io_counter ; Lwt.return ()
let n = 100
module DCPS = struct
type (_, _) kont =
| KHalt : ('a, 'a) kont
| KPush : 'x * ('x * 'a, 'f) kont -> ('a, 'f) kont
| KMul : (z * 'a, 'f) kont -> (z * (z * 'a), 'f) kont
| KDec : (z * 'a, 'f) kont -> (z * 'a, 'f) kont
| KCmpNZ : (bool * 'a, 'f) kont -> (z * 'a, 'f) kont
| KLoop : ('a, bool * 'a) kont * ('a, 'f) kont -> (bool * 'a, 'f) kont
| KDup : ('x * ('x * 'a), 'f) kont -> ('x * 'a, 'f) kont
| KSwap : ('x * ('y * 'a), 'f) kont -> ('y * ('x * 'a), 'f) kont
| KDrop : ('s, 'f) kont -> ('a * 's, 'f) kont
| KDip : ('t, 's) kont * ('a * 's, 'f) kont -> ('a * 't, 'f) kont
| KIO : (z * 'a, 'f) kont -> (z * 'a, 'f) kont
let push n k = KPush (n, k)
let dup k = KDup k
let mul k = KMul k
let dec k = KDec k
let cmpnz k = KCmpNZ k
let loop i k = KLoop (i, k)
let swap k = KSwap k
let drop k = KDrop k
let dip i k = KDip (i, k)
let kio k = KIO k
let ( !! ) i = i KHalt
let fact n =
assert (
let open Z in
n > zero ) ;
push n @@ dup
@@ push (Z.of_int 1)
@@ dup @@ cmpnz @@ dip !!swap
@@ loop
(dup @@ dip !!swap @@ mul @@ kio @@ swap @@ dec @@ dup @@ !!cmpnz)
!!drop
let factn = fact (Z.of_int n)
module SmallStep = struct
type (_, _) konts =
| KNil : ('a, 'a) konts
| KCons : ('a, 'b) kont * ('b, 'c) konts -> ('a, 'c) konts
let step : type a b. (a, b) kont -> a -> b Lwt.t =
fun i stack ->
let rec exec : type a i. (a, i) kont -> (i, b) konts -> a -> b Lwt.t =
fun k ks s ->
match (k, ks) with
| (KHalt, KNil) ->
Lwt.return s
| (KHalt, KCons (k, ks)) ->
exec k ks s
| (KIO k, ks) ->
let (z, _) = s in
Lwt.bind (io z) (fun () -> exec k ks s)
| (KPush (z, k), ks) ->
exec k ks (z, s)
| ((KLoop (ki, k) as loop), ks) -> (
match s with
| (true, s) ->
exec ki (KCons (loop, ks)) s
| (false, s) ->
exec k ks s )
| (KMul k, ks) ->
let (x, (y, s)) = s in
exec k ks (Z.mul x y, s)
| (KDec k, ks) ->
let (x, s) = s in
exec k ks (Z.sub x (Z.of_int 1), s)
| (KCmpNZ k, ks) ->
let (x, s) = s in
exec
k
ks
( (let open Z in
compare x zero)
<> 0,
s )
| (KDup k, ks) ->
let (x, s) = s in
exec k ks (x, (x, s))
| (KSwap k, ks) ->
let (x, (y, s)) = s in
exec k ks (y, (x, s))
| (KDrop k, ks) ->
let (_, s) = s in
exec k ks s
| (KDip (ki, k), ks) ->
let (x, s) = s in
exec ki (KCons (KPush (x, k), ks)) s
in
exec i KNil stack
let eval () =
Lwt_main.run (Lwt.bind (step factn ()) (fun (z, _) -> Lwt.return z))
end
end
module DCPS' = struct
type (_, _) instr =
| Push : 'x -> ('a, 'x * 'a) instr
| Mul : (z * (z * 'a), z * 'a) instr
| Dec : (z * 'a, z * 'a) instr
| CmpNZ : (z * 'a, bool * 'a) instr
| Dup : ('x * 'a, 'x * ('x * 'a)) instr
| Swap : ('y * ('x * 'a), 'x * ('y * 'a)) instr
| Drop : ('a * 's, 's) instr
| IO : (z * 'a, z * 'a) instr
and (_, _) control =
| KHalt : ('a, 'a) control
| KNext : ('b, 't) instr * ('t, 'a) control -> ('b, 'a) control
| KLoop :
('a, bool * 'a) control * ('a, 'f) control
-> (bool * 'a, 'f) control
| KDip : ('t, 's) control * ('a * 's, 'f) control -> ('a * 't, 'f) control
and (_, _) konts =
| KNil : ('a, 'a) konts
| KCons : ('a, 'b) control * ('b, 'c) konts -> ('a, 'c) konts
let ( @ ) l r = KNext (l, r)
let dip i k = KDip (i, k)
let loop i k = KLoop (i, k)
let fact n =
assert (
let open Z in
n > zero ) ;
Push n @ Dup
@ Push (Z.of_int 1)
@ Dup @ CmpNZ
@ dip (Swap @ KHalt)
@@ loop
( Dup
@ dip (Swap @ KHalt)
@@ Mul @ IO @ Swap @ Dec @ Dup @ CmpNZ @ KHalt )
(Drop @ KHalt)
let factn = fact (Z.of_int n)
module SmallStep = struct
let rec step_control :
type b t a. (b, t) control -> (t, a) konts -> b -> a Lwt.t =
fun (type b t a) ->
( fun control konts stack ->
let step_instr :
type b t t' a.
(b, t) instr -> (t, t') control -> (t', a) konts -> b -> a Lwt.t
=
fun (type b t t' a) ->
( fun k control konts s ->
let step_control s =
step_control control konts s
[@@inline always]
in
match (k, s) with
| (IO, (z, _)) ->
Lwt.bind (io z) (fun () -> step_control s)
| (Push z, s) ->
step_control (z, s)
| (Mul, (x, (y, s))) ->
step_control (Z.mul x y, s)
| (Dec, (x, s)) ->
step_control (Z.sub x (Z.of_int 1), s)
| (CmpNZ, (x, s)) ->
step_control
( (let open Z in
compare x zero)
<> 0,
s )
| (Dup, (x, s)) ->
step_control (x, (x, s))
| (Swap, (x, (y, s))) ->
step_control (y, (x, s))
| (Drop, (_, s)) ->
step_control s
: (b, t) instr ->
(t, t') control ->
(t', a) konts ->
b ->
a Lwt.t )
[@@inline always]
in
match (control, konts, stack) with
| (KHalt, KNil, s) ->
Lwt.return s
| (KHalt, KCons (k, ks), s) ->
step_control k ks s
| (KNext (instr, control), konts, s) ->
(step_instr [@inlined]) instr control konts s
| ((KLoop (ki, _) as loop), konts, (true, s)) ->
step_control ki (KCons (loop, konts)) s
| (KLoop (_, control), konts, (false, stack)) ->
step_control control konts stack
| (KDip (ki, control), konts, (x, s)) ->
step_control ki (KCons (KNext (Push x, control), konts)) s
: (b, t) control -> (t, a) konts -> b -> a Lwt.t )
let step control stack = step_control control KNil stack
let eval () =
Lwt_main.run (Lwt.bind (step factn ()) (fun (z, _) -> Lwt.return z))
end
end
module DCPS'' = struct
type (_, _) instr =
| Push : 'x -> ('a, 'x * 'a) instr
| Mul : (z * (z * 'a), z * 'a) instr
| Dec : (z * 'a, z * 'a) instr
| CmpNZ : (z * 'a, bool * 'a) instr
| Dup : ('x * 'a, 'x * ('x * 'a)) instr
| Swap : ('y * ('x * 'a), 'x * ('y * 'a)) instr
| Drop : ('a * 's, 's) instr
| IO : (z * 'a, z * 'a) instr
| KLoop : ('a, bool * 'a) control -> (bool * 'a, 'a) instr
| KDip : ('t, 's) control -> ('a * 't, 'a * 's) instr
and (_, _) control =
| KHalt : ('a, 'a) control
| KNext : ('b, 't) instr * ('t, 'a) control -> ('b, 'a) control
and (_, _) konts =
| KNil : ('a, 'a) konts
| KCons : ('a, 'b) control * ('b, 'c) konts -> ('a, 'c) konts
let ( @ ) l r = KNext (l, r)
let fact n =
assert (
let open Z in
n > zero ) ;
Push n @ Dup
@ Push (Z.of_int 1)
@ Dup @ CmpNZ
@ KDip (Swap @ KHalt)
@ KLoop
( Dup
@ KDip (Swap @ KHalt)
@ Mul @ IO @ Swap @ Dec @ Dup @ CmpNZ @ KHalt )
@ Drop @ KHalt
let factn = fact (Z.of_int n)
module SmallStep = struct
let rec step_control :
type b t a. (b, t) control -> (t, a) konts -> b -> a Lwt.t =
fun control konts s ->
let step_instr :
type b t t' a.
(b, t) instr -> (t, t') control -> (t', a) konts -> b -> a Lwt.t =
fun (type b t t' a) ->
( fun k control konts s ->
let step_control' = step_control in
let step_control s =
step_control control konts s
[@@inline always]
in
match (k, s) with
| (IO, (z, _)) ->
Lwt.bind (io z) (fun () -> step_control s)
| (Push z, s) ->
step_control (z, s)
| (Mul, (x, (y, s))) ->
step_control (Z.mul x y, s)
| (Dec, (x, s)) ->
step_control (Z.sub x (Z.of_int 1), s)
| (CmpNZ, (x, s)) ->
step_control
( (let open Z in
compare x zero)
<> 0,
s )
| (Dup, (x, s)) ->
step_control (x, (x, s))
| (Swap, (x, (y, s))) ->
step_control (y, (x, s))
| (Drop, (_, s)) ->
step_control s
| ((KLoop ki as loop), (true, s)) ->
step_control'
ki
(KCons ((KNext (loop, control) [@explicit_arity]), konts))
s
| (KLoop _, (false, stack)) ->
step_control' control konts stack
| (KDip ki, (x, s)) ->
step_control' ki (KCons (KNext (Push x, control), konts)) s
: (b, t) instr -> (t, t') control -> (t', a) konts -> b -> a Lwt.t
)
[@@inline always]
in
match (control, konts) with
| (KHalt, KNil) ->
Lwt.return s
| (KHalt, KCons (k, ks)) ->
step_control k ks s
| (KNext (instr, control), konts) ->
(step_instr [@inlined]) instr control konts s
let step : type b a. (b, a) control -> b -> a Lwt.t =
fun control stack -> step_control control KNil stack
let eval () =
Lwt_main.run (Lwt.bind (step factn ()) (fun (z, _) -> Lwt.return z))
end
end
module DCPS''' = struct
type (_, _) instr =
| Push : 'x -> ('a, 'x * 'a) instr
| Mul : (z * (z * 'a), z * 'a) instr
| Dec : (z * 'a, z * 'a) instr
| CmpNZ : (z * 'a, bool * 'a) instr
| Dup : ('x * 'a, 'x * ('x * 'a)) instr
| Swap : ('y * ('x * 'a), 'x * ('y * 'a)) instr
| Drop : ('a * 's, 's) instr
| IO : (z * 'a, z * 'a) instr
| KLoop : ('a, bool * 'a) instr -> (bool * 'a, 'a) instr
| KDip : ('t, 's) instr -> ('a * 't, 'a * 's) instr
| KSeq : ('b, 't) instr * ('t, 'a) instr -> ('b, 'a) instr
and (_, _) konts =
| KNil : ('a, 'a) konts
| KCons : ('a, 'b) instr * ('b, 'c) konts -> ('a, 'c) konts
let ( @ ) l r = KSeq (l, r)
let fact n =
assert (
let open Z in
n > zero ) ;
Push n @ Dup
@ Push (Z.of_int 1)
@ Dup @ CmpNZ @ KDip Swap
@ KLoop (Dup @ KDip Swap @ Mul @ IO @ Swap @ Dec @ Dup @ CmpNZ)
@ Drop
let factn = fact (Z.of_int n)
module SmallStep = struct
let rec step_konts : type b a. (b, a) konts -> b -> a Lwt.t =
fun konts s ->
let rec step_instr :
type b t a. (b, t) instr -> (t, a) konts -> b -> a Lwt.t =
fun k konts s ->
let step_konts' = step_konts in
let step_konts s = step_konts konts s [@@inline always] in
match (k, s) with
| (IO, (z, _)) ->
Lwt.bind (io z) (fun () -> step_konts s)
| (Push z, s) ->
step_konts (z, s)
| (Mul, (x, (y, s))) ->
step_konts (Z.mul x y, s)
| (Dec, (x, s)) ->
step_konts (Z.sub x (Z.of_int 1), s)
| (CmpNZ, (x, s)) ->
step_konts
( (let open Z in
compare x zero)
<> 0,
s )
| (Dup, (x, s)) ->
step_konts (x, (x, s))
| (Swap, (x, (y, s))) ->
step_konts (y, (x, s))
| (Drop, (_, s)) ->
step_konts s
| ((KLoop ki as loop), (true, s)) ->
step_instr ki (KCons (loop, konts)) s
| (KLoop _, (false, stack)) ->
step_konts' konts stack
| (KDip ki, (x, s)) ->
step_instr ki (KCons (Push x, konts)) s
| (KSeq (left, right), s) ->
step_instr left (KCons (right, konts)) s
in
match konts with
| KNil ->
Lwt.return s
| KCons (instr, konts) ->
(step_instr [@inlined]) instr konts s
let step : type b a. (b, a) instr -> b -> a Lwt.t =
fun instr s -> step_konts (KCons (instr, KNil)) s
let eval () =
Lwt_main.run (Lwt.bind (step factn ()) (fun (z, _) -> Lwt.return z))
end
end
module DCPS'''' = struct
type (_, _) instr =
| Push : 'x -> ('a, 'x * 'a) instr
| Mul : (z * (z * 'a), z * 'a) instr
| Dec : (z * 'a, z * 'a) instr
| CmpNZ : (z * 'a, bool * 'a) instr
| Dup : ('x * 'a, 'x * ('x * 'a)) instr
| Swap : ('y * ('x * 'a), 'x * ('y * 'a)) instr
| Drop : ('a * 's, 's) instr
| IO : (z * 'a, z * 'a) instr
| KLoop : ('a, bool * 'a) konts -> (bool * 'a, 'a) instr
| KDip : ('t, 's) konts -> ('a * 't, 'a * 's) instr
and (_, _) konts =
| KNil : ('a, 'a) konts
| KSeq : ('b, 't) konts * ('t, 'a) konts -> ('b, 'a) konts
| KCons : ('a, 'b) instr * ('b, 'c) konts -> ('a, 'c) konts
let ( @ ) l r = KCons (l, r)
let fact n =
assert (
let open Z in
n > zero ) ;
Push n @ Dup
@ Push (Z.of_int 1)
@ Dup @ CmpNZ
@ KDip (Swap @ KNil)
@ KLoop
(Dup @ KDip (Swap @ KNil) @ Mul @ IO @ Swap @ Dec @ Dup @ CmpNZ @ KNil)
@ Drop @ KNil
let factn = fact (Z.of_int n)
module SmallStep = struct
let rec step : type b a. (b, a) konts -> b -> a Lwt.t =
fun konts s ->
let step_instr : type b t a. (b, t) instr -> (t, a) konts -> b -> a Lwt.t
=
fun k konts s ->
let step' = step in
let step s = step konts s [@@inline always] in
match (k, s) with
| (IO, (z, _)) ->
Lwt.bind (io z) (fun () -> step s)
| (Push z, s) ->
step (z, s)
| (Mul, (x, (y, s))) ->
step (Z.mul x y, s)
| (Dec, (x, s)) ->
step (Z.sub x (Z.of_int 1), s)
| (CmpNZ, (x, s)) ->
step
( (let open Z in
compare x zero)
<> 0,
s )
| (Dup, (x, s)) ->
step (x, (x, s))
| (Swap, (x, (y, s))) ->
step (y, (x, s))
| (Drop, (_, s)) ->
step s
| ((KLoop ki as loop), (true, s)) ->
step' (KSeq (ki, KCons (loop, konts))) s
| (KLoop _, (false, stack)) ->
step' konts stack
| (KDip ki, (x, s)) ->
step' (KSeq (ki, KCons (Push x, konts))) s
in
let rec step_konts_seq :
type b t a. (b, t) konts -> (t, a) konts -> b -> a Lwt.t =
fun left right s ->
match (left, right) with
| (KNil, konts) ->
step konts s
| (KCons (instr, left), right) ->
(step_instr [@inlined]) instr (KSeq (left, right)) s
| (KSeq (first, left), right) ->
step_konts_seq first (KSeq (left, right)) s
in
match konts with
| KNil ->
Lwt.return s
| KSeq (left, right) ->
(step_konts_seq [@inlined]) left right s
| KCons (instr, konts) ->
(step_instr [@inlined]) instr konts s
let eval () =
Lwt_main.run (Lwt.bind (step factn ()) (fun (z, _) -> Lwt.return z))
end
end
open Core
open Core_bench
let main () =
let log fn = fn () |> Z.to_string |> Printf.printf "v: %s\n" in
log DCPS.SmallStep.eval ;
log DCPS'.SmallStep.eval ;
log DCPS''.SmallStep.eval ;
log DCPS'''.SmallStep.eval ;
log DCPS''''.SmallStep.eval ;
Command.run
(Bench.make_command
[ Bench.Test.create ~name:"dcps" (fun () -> DCPS.SmallStep.eval ());
Bench.Test.create ~name:"dcps'" (fun () -> DCPS'.SmallStep.eval ());
Bench.Test.create ~name:"dcps''" (fun () -> DCPS''.SmallStep.eval ());
Bench.Test.create ~name:"dcps'''" (fun () ->
DCPS'''.SmallStep.eval ());
Bench.Test.create ~name:"dcps''''" (fun () ->
DCPS'''.SmallStep.eval ()) ])
let () = main ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment