gctest.dats

(*
 * to compile:
 *
 *   $ patscc -DATS_MEMALLOC_LIBC gctest.dats
 *
 * NOTE: no GC here
*)
#include
"share/atspre_staload.hats"

(*
// from: http://stackoverflow.com/questions/36772017/reducing-garbage-collection-pause-time-in-a-haskell-program
module Main (main) where

import qualified Control.Exception as Exception
import qualified Control.Monad as Monad
import qualified Data.ByteString as ByteString
import qualified Data.Map.Strict as Map

data Msg = Msg !Int !ByteString.ByteString

type Chan = Map.Map Int ByteString.ByteString

message :: Int -> Msg
message n = Msg n (ByteString.replicate 1024 (fromIntegral n))

pushMsg :: Chan -> Msg -> IO Chan
pushMsg chan (Msg msgId msgContent) =
  Exception.evaluate $
    let
      inserted = Map.insert msgId msgContent chan
    in
      if 200000 < Map.size inserted
      then Map.deleteMin inserted
      else inserted

main :: IO ()
main = Monad.foldM_ pushMsg Map.empty (map message [1..1000000])
*)

(*
 * this runs in about 1min on Cloud-9 Ubuntu box,
 * taking as much as ~240 MB RAM (and not much more)
*)

staload "libats/SATS/linmap_randbst.sats"

staload
_(*anon*) = "libats/DATS/qlist.dats"
staload
_(*anon*) = "libats/DATS/linmap_randbst.dats"

vtypedef Msg = @(int, Strnptr1)
typedef key = int
vtypedef itm = Msg
vtypedef Chan = map (key, itm)

fun
message (n: int, res: &Msg? >> Msg): void = {
  val () = res.0 := n
  val c = (g1ofg0)(int2char0 n)
  val c = (if c > '\000' then c else 'a') : charNZ (* FIXME: what does Haskell's fromIntegral do? *)
  implement
  string_tabulate$fopr<> (_) = c
  val () = res.1 := string_tabulate<> ((i2sz)1024)
  (*
message :: Int -> Msg
message n = Msg n (ByteString.replicate 1024 (fromIntegral n))
  *)
}
fun
message_free (x: &Msg >> _?): void = strnptr_free (x.1)

fun
pushMsg (chan: &Chan >> _, msg: &Msg >> _?, minkey: int): int = let
  var res: Msg
  val ans = linmap_insert (chan, msg.0, msg, res)
  val () =
    if :(res: Msg?) => ans then let
      prval () = opt_unsome {Msg} (res)
      val () = message_free (res)
    in
    end else let
      prval () = opt_unnone {Msg} (res)
    in
    end
  (* NOTE: for Haskell Data.Map.Strict, size is O(1),
   * but for linmap_avltree, linmap_size is O(n),
   * which is why we use linmap_randbst (O(1) for size)
   *)
  val sz = linmap_size (chan)
in
  if :(chan: Chan, res: Msg?) => (g0ofg1)((i2sz)200000) < sz then let
    (* strangely, no such function (takeout min) is exposed in the API
     * but it's there in the implementation of linmap_avltree
     *)
    val ans = linmap_takeout (chan, minkey, res)
  in
    if :(chan: Chan, res: Msg?) => ans then let
      prval () = opt_unsome {Msg} (res)
      val () = message_free (res)
    in
      succ(minkey)
    end else let
      prval () = opt_unnone {Msg} (res)
    in
      minkey (* FIXME: shouldn't happen? will happen at the end! *)
    end
  end else minkey
end

vtypedef VT = map(key,itm)

val (
) = linmap_randbst_initize<> ()

implement
main0 () = let
  var map = linmap_make_nil {key,itm} ()
  var minkey = (g0ofg1)1
  prval pf_minkey = view@ (minkey)

  implement
  intrange_foreach$fwork<VT> (i, env) = {
    var msg: Msg
    val () = if (i % 10000) = 0 then println!("i = ", i) // report progress
    val () = message (i, msg)
    prval (pf_key, fpf) = decode($vcopyenv_v(pf_minkey))
    val minkey1 = pushMsg (env, msg, minkey)
    val () = minkey := minkey1
    prval () = fpf (pf_key)
  }
  val _ = intrange_foreach_env<VT> (1, 1000000, map)
  prval () = view@(minkey) := pf_minkey
  
  implement
  linmap_freelin$clear<itm> (x) = $effmask_all (message_free (x))
  val () = linmap_freelin (map)
in
end