Skip to content

Instantly share code, notes, and snippets.

@jameshfisher
Forked from ashalkhakov/gctest.dats
Created November 10, 2016 16:58
Show Gist options
  • Save jameshfisher/25f8dd966e42dbbbf3212dc0d895143d to your computer and use it in GitHub Desktop.
Save jameshfisher/25f8dd966e42dbbbf3212dc0d895143d to your computer and use it in GitHub Desktop.
(*
* 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment