[Header]
open Libsm5
open Sm5

exception GC_Incorrect of string

(* Check if malloc_with_gc respects GC spec *)
let malloc =
  let mem_limit = 128 in
  fun ((_, m, _, _, _) as smeck : smeck) ->
    let old_len = List.length m in
    let new_l, new_m = Gc.malloc_with_gc smeck in
    let new_len = List.length new_m in
    if old_len < mem_limit && new_len < old_len then (
      raise (GC_Incorrect "collected when free memory available")
    )
    else if new_len > mem_limit then (
      raise (GC_Incorrect "memory limit exceeded")
    )
    else
      (new_l, new_m)

let run cmd =
  try
    run ~debug:false ~malloc cmd
  with
  | GC_Incorrect msg -> print_endline ("GC_Incorrect: " ^ msg)

(* concat command n times *)
let append (n: int) (f: int -> command) (cmd: command) : command =
  let rec iter i =
    if i = n then []
    else (f i) @ iter (i + 1) in cmd @ (iter 0)

[Test]
(* 1. Simple malloc & use : trigger gc and fail *)
let cmds1 =
  let cmds = append 129 (fun i ->
    let value = Printf.sprintf "x%d" i in [
        MALLOC;
        BIND value;
        PUSH (Val (Z i));
        PUSH (Id value);
        STORE;
      ])
    []
  in

  (* Access all the allocated memory locations, ensuring they must not have been collected *)
    let cmds = append 128 (fun i ->
        let value = Printf.sprintf "x%d" i in [
            PUSH (Id value);
            LOAD;
            POP;
         ]) cmds in

    cmds
in
run cmds1

[Exception]
GC_Failure


[Test]
(* 2. Simple malloc & use : trigger gc and success *)
let cmds2 =
    (* To be collected *)
    let cmds = [
        PUSH (Val (Z 1));
        MALLOC;
        STORE;
    ] in

    let cmds = append 127 (fun i ->
        let v = Printf.sprintf "x%d" i in [
            MALLOC;
            BIND v;
            PUSH (Val (Z 1));
            PUSH (Id v);
            STORE;
        ]) cmds in

    (* Trigger GC *)
    let cmds = cmds @ [
        MALLOC;
        BIND "x_new";
        PUSH (Val (Z 50));
        PUSH (Val (Z 10));
        ADD;
        PUSH (Id "x_new");
        STORE;

        PUSH (Id "x_new");
        LOAD;
    ] in

    (* Check if allocated memory location's values are not affected by GC() *)
    let cmds = append 127 (fun i ->
        let v = Printf.sprintf "x%d" i in [
            PUSH (Id v);
            LOAD;
            ADD;
         ]) cmds in

    let cmds = cmds @ [PUT] in

    cmds
in
run cmds2

[Output]
187


[Test]
(* 3. GC must be able to track the location chain : gc fail *)
let cmds3 =
  let cmds = [
    MALLOC;
    BIND "start";
    PUSH (Id "start");
    BIND "cur";
  ] in

  let cmds = append 127 (fun _ ->
    [
      MALLOC;
      PUSH (Id "cur");
      STORE;

      PUSH (Id "cur");
      LOAD;

      UNBIND;
      POP;

      BIND "cur";
    ]) cmds in

  let cmds = cmds @ [PUSH (Val (Z 100)); PUSH (Id "cur"); STORE] in

  (* Trigger GC *)
  let cmds = cmds @ [
    MALLOC;
    BIND "foo";
    PUSH (Val (Z 1));
    PUSH (Id "foo");
    STORE
    ]
  in

  let cmds = cmds @ [PUSH (Val (Z 1)); PUSH (Id "start")] in

  (* Access all the allocated memory locations, ensuring they must not have been collected *)
  let cmds = append 127 (fun _ ->
    [LOAD;]
    ) cmds
  in

  cmds @ [STORE]
in
run cmds3

[Exception]
GC_Failure

[Test]
(* 4. Gc must be able to track the location chain : gc success *)

let cmds4 =
  (* To be collected *)
  let cmds = [
      PUSH (Val (Z 1));
      MALLOC;
      STORE;
  ] in

  let cmds = cmds @ [
    MALLOC;
    BIND "start";
    PUSH (Id "start");
    BIND "cur";
  ] in

  (* 126 times instead of 127 *)
  let cmds = append 126 (fun _ ->
    [
      MALLOC;
      PUSH (Id "cur");
      STORE;

      PUSH (Id "cur");
      LOAD;

      UNBIND;
      POP;

      BIND "cur";
    ]) cmds in

  let cmds = cmds @ [PUSH (Val (Z 99)); PUSH (Id "cur"); STORE] in

  (* Trigger GC *)
  let cmds = cmds @ [
    MALLOC;
    BIND "foo";
    PUSH (Val (Z 1));
    PUSH (Id "foo");
    STORE
    ]
  in

  let cmds = cmds @ [PUSH (Id "start")] in

  (* Access all the allocated memory locations, ensuring they must not have been collected *)
  let cmds = append 126 (fun _ ->
    [LOAD;]
    ) cmds
  in

  cmds @ [LOAD; PUT]
in
run cmds4

[Output]
99


[Test]
(* 5. Alternatedly : gc success *)
let cmds5 =
    (* Trigger GC *)
    let cmds =
    append 128 (fun i ->
        let v = Printf.sprintf "x%d" i in [
            (* To be collected *)
            PUSH (Val (Z 1));
            MALLOC;
            STORE;

            (* Not to be collected *)
            MALLOC;
            BIND v;
            PUSH (Val (Z 10));
            PUSH (Id v);
            STORE
            ])
    [] in

    (* Check if allocated memory location's values are not affected by GC() *)
    let cmds =
    append 128
      (fun i ->
        let v = Printf.sprintf "x%d" i in [
            PUSH (Id v);
            LOAD;
            ADD;
            ]
      ) (cmds @ [PUSH (Val (Z 0))])
    in

    let cmds = cmds @ [PUT] in

    cmds
in
run cmds5

[Output]
1280


[Test]
(* 6. Alternatedly : gc fail *)
let cmds6 =
  (* Trigger GC *)
  let cmds =
  append 128 (fun i ->
    let v = Printf.sprintf "x%d" i in [
      (* Not to be collected *)
      MALLOC;
      BIND v;
      PUSH (Val (Z 1));
      PUSH (Id v);
      STORE;

      (* To be collected *)
      PUSH (Val (Z 1));
      MALLOC;
      STORE
      ])
  [] in

  (* Check if allocated memory location's values are not affected by GC() *)
  let cmds =
  append 128
    (fun i ->
      let v = Printf.sprintf "x%d" i in [
        PUSH (Id v);
        LOAD;
        ADD;
        ]
    ) (cmds @ [PUSH (Val (Z 0))])
  in

  let cmds = cmds @ [PUT] in

  cmds
in
run cmds6

[Exception]
GC_Failure


[Test]
(* 7. Gc must be able to track record : gc fail *)
let cmds7 =
  let cmds = append 124 (fun i ->
      let v = Printf.sprintf "x%d" i in [
        MALLOC;
        BIND v;
        PUSH (Val (Z i));
        PUSH (Id v);
        STORE;
      ])
  [] in

  let cmds = cmds @ [
    MALLOC;
    BIND "x";
    PUSH (Val (Z 100));
    PUSH (Id "x");
    STORE;

    MALLOC;
    BIND "loc_field";
    PUSH (Id "x");
    PUSH (Id "loc_field");
    STORE;
    UNBIND;

    MALLOC;
    BIND "z_field";
    PUSH (Val (Z 200));
    PUSH (Id "z_field");
    STORE;

    UNBIND;
    BOX 2;

    MALLOC;
    BIND "box";

    PUSH (Id "box");
    STORE;

    (* Trigger GC *)
    PUSH (Val (Z 1));
    MALLOC;
    STORE;
  ] in

  (* Access all the allocated memory locations, ensuring they must not have been collected *)
  let cmds = append 124 (fun i ->
      let v = Printf.sprintf "x%d" i in [
          PUSH (Id v);
          LOAD;
          POP;
       ]) cmds
  in

  let cmds = cmds @ [
    PUSH (Id "box");
    LOAD;
    UNBOX "z_field";
    LOAD;
    PUT;
    ]
  in
  let cmds = cmds @ [
    PUSH (Id "box");
    LOAD;
    UNBOX "loc_field";
    LOAD;
    LOAD;
    PUT;
    ]
  in
  cmds
in
run cmds7

[Exception]
GC_Failure


[Test]
(* 8. Gc must be able to track record : gc success *)
let cmds8 =
  let cmds = append 123 (fun i ->
      let v = Printf.sprintf "x%d" i in [
        MALLOC;
        BIND v;
        PUSH (Val (Z i));
        PUSH (Id v);
        STORE;
      ])
  [] in

  let cmds = cmds @ [
    MALLOC;
    BIND "x";
    PUSH (Val (Z 100));
    PUSH (Id "x");
    STORE;

    MALLOC;
    BIND "loc_field";
    PUSH (Id "x");
    PUSH (Id "loc_field");
    STORE;
    UNBIND;

    MALLOC;
    BIND "z_field";
    PUSH (Val (Z 200));
    PUSH (Id "z_field");
    STORE;

    UNBIND;
    BOX 2;

    MALLOC;
    BIND "box";

    PUSH (Id "box");
    STORE;

    (* Trigger GC *)
    PUSH (Val (Z 1));
    MALLOC;
    STORE;
  ] in

  (* Access all the allocated memory locations, ensuring they must not have been collected *)
  let cmds = append 123 (fun i ->
      let v = Printf.sprintf "x%d" i in [
          PUSH (Id v);
          LOAD;
          POP;
       ]) cmds
  in

  let cmds = cmds @ [
    PUSH (Id "box");
    LOAD;
    UNBOX "loc_field";
    LOAD;
    LOAD;
    PUT;
    ]
  in

  let cmds = cmds @ [
    PUSH (Id "box");
    LOAD;
    UNBOX "z_field";
    LOAD;
    PUT;
    ]
  in

  cmds
in
run cmds8

[Output]
100
200


[Test]
(* 9. Location allocated in function can be collected in 2nd call : gc success *)
let cmds9 =
    let cmds = [
        PUSH (Fn ("x", [
            (* Trigger GC / At the same time, to be collected in the second call *)
            MALLOC;
            BIND "local";
            PUSH (Val (Z 1));
            PUSH (Id "local");
            STORE;

            (* Access argument location, ensuring it must not have been collected *)
            PUSH (Id "x");
            LOAD;
            POP;
        ]));

        BIND "f";
    ] in

    let cmds = append 126 (fun i ->
        let v = Printf.sprintf "x%d" i in [
            MALLOC;
            BIND v;
            PUSH (Val (Z 2));
            PUSH (Id v);
            STORE;
        ]) cmds in

    let cmds = cmds @ [
        MALLOC;
        BIND "arg";

        (* First Call *)
        PUSH (Id "f");
        PUSH (Val (Z 1));
        PUSH (Id "arg");
        CALL;

        (* Second Call *)
        PUSH (Id "f");
        PUSH (Val (Z 2));
        PUSH (Id "arg");
        CALL;
    ] in

    (* Check if allocated memory location's values are not affected by GC() *)
    let cmds =
      append 126
        (fun i ->
          let v = Printf.sprintf "x%d" i in
            [PUSH (Id v);
            LOAD;
            ADD]
        ) (cmds @ [PUSH (Val (Z 0));]) in

    let cmds = cmds @ [PUT] in
    cmds
in
run cmds9

[Output]
252


[Test]
(* 10. Location allocated in function can be collected in 2nd call : gc fail *)
let cmds10 =
    let cmds = [
        PUSH (Fn ("x", [
            (* Trigger GC / At the same time, to be collected in the second call *)
            MALLOC;
            BIND "local";
            PUSH (Val (Z 1));
            PUSH (Id "local");
            STORE;

            (* Access argument location, ensuring it must not have been collected *)
            PUSH (Id "x");
            LOAD;
            POP;
        ]));

        BIND "f";
    ] in

    let cmds = append 126 (fun i ->
        let v = Printf.sprintf "x%d" i in [
            MALLOC;
            BIND v;
            PUSH (Val (Z 2));
            PUSH (Id v);
            STORE;
        ]) cmds in

    let cmds = cmds @ [
        MALLOC;
        BIND "arg";

        (* First Call *)
        PUSH (Id "f");
        PUSH (Val (Z 1));
        PUSH (Id "arg");
        CALL;

        (* Allocate and bind new loc *)
        MALLOC;
        BIND "tmp";
        PUSH (Val (Z 3));
        PUSH (Id "tmp");
        STORE;

        (* Second Call *)
        PUSH (Id "f");
        PUSH (Val (Z 2));
        PUSH (Id "arg");
        CALL;
    ] in

    (* Check if allocated memory location's values are not affected by GC() *)
    let cmds =
      append 126
        (fun i ->
          let v = Printf.sprintf "x%d" i in
            [PUSH (Id v);
            LOAD;
            ADD]
        ) (cmds @ [PUSH (Val (Z 0));]) in

    let cmds = cmds @ [
      PUSH (Id "tmp");
      LOAD;
      ADD;
      PUT
      ]
    in
    cmds
in
run cmds10

[Exception]
GC_Failure