Re: [Haskell-cafe] Rewrite NetBSD kernel driver using Ajhc Haskell compiler

[Kiwamu Okabe <kiwamu%debian.or.jp@localhost>]

Hi Johnny,

On Thu, Feb 20, 2014 at 5:37 PM, Johnny Billquist <bqt%update.uu.se@localhost> 
wrote:
> Are you saying that you essentially avoid GC by creating a large fresh heap
> every time you call something written in Haskell, and then delete the heap
> when the Haskell function returns? And that the current piece of code
> running in Haskell is short enough that GC never is done?

No, does not delete. Pool it.
See following code compiled by Ajhc.
Ajhc compile Haskell code into C code.

https://gist.github.com/master-q/9109334

Please note auichIntr() function that is entry point C => Haskell.

https://gist.github.com/master-q/9109334#file-hsmain-c-L2051

int
auichIntr(HsPtr x272)
{
        arena_t arena;
        gc_t gc;
        gc = NULL;
        arena = NULL;
        jhc_alloc_init(&gc,&arena);
        jhc_hs_init(gc,arena);
        int x273 = ((int)fFE$__CCall_auichIntr(gc,arena,(uintptr_t)x272));
        jhc_alloc_fini(gc,arena);
        return x273;
}

The code post-calls jhc_alloc_fini() that pool Haskell heap (named
megablock) into free_megablocks.

https://github.com/ajhc/ajhc/blob/d93468e34f4514209048d4a92b1549e079ccd3fb/rts/rts/gc_jgc.c#L251

void
jhc_alloc_fini(gc_t gc,arena_t arena) {
-- snip --
        SLIST_FOREACH(pg, &arena->monolithic_blocks, link) {
                SLIST_INSERT_HEAD(&free_monolithic_blocks, pg, link);
        }
        SLIST_FOREACH(mb, &arena->megablocks, next) {
                SLIST_INSERT_HEAD(&free_megablocks, mb, next);
        }
        if(arena->current_megablock) {
                SLIST_INSERT_HEAD(&free_megablocks,
arena->current_megablock, next);
        }

Also s_alloc(), Haskell heap allocator, try to get Haskell heap from the pool.
If not found, it posix_memalign new megablock.

https://github.com/ajhc/ajhc/blob/d93468e34f4514209048d4a92b1549e079ccd3fb/rts/rts/gc_jgc.c#L392

struct s_megablock *
s_new_megablock(arena_t arena)
{
        jhc_rts_lock();
        struct s_megablock *mb = SLIST_FIRST(&free_megablocks);
        if (mb) {
                SLIST_REMOVE(&free_megablocks, mb, s_megablock, next);
        } else {
                mb = malloc(sizeof(*mb));
#ifdef _JHC_JGC_LIMITED_NUM_MEGABLOCK
                static int count = 0;
                if (count >= _JHC_JGC_LIMITED_NUM_MEGABLOCK) {
                        abort();
                }
                mb->base = aligned_megablock + (MEGABLOCK_SIZE) * count;
                count++;
#else
                mb->base = jhc_aligned_alloc(MEGABLOCK_SIZE);
#endif

Regards,
-- 
Kiwamu Okabe