なぜかjhc+stm32でサンクヒープを使うとクラッシュする。。。Main.hs=>hs_main.cに変換するんだけど、二回目？のeval()で停止する。。。 https://gist.github.com/master-q/5001451#file-hs_main-c-L112

hs_main.c

char jhc_c_compile[] = "gcc /tmp/jhc_raMpOm/rts/profile.c /tmp/jhc_raMpOm/rts/rts_support.c /tmp/jhc_raMpOm/rts/gc_none.c /tmp/jhc_raMpOm/rts/jhc_rts.c /tmp/jhc_raMpOm/lib/lib_cbits.c /tmp/jhc_raMpOm/rts/gc_jgc.c /tmp/jhc_raMpOm/rts/stableptr.c -I/tmp/jhc_raMpOm/cbits -I/tmp/jhc_raMpOm hs_main.c -o hs_main.c '-std=gnu99' -D_GNU_SOURCE '-falign-functions=4' -ffast-math -Wextra -Wall -Wno-unused-parameter -fno-strict-aliasing -DNDEBUG -O3 '-D_JHC_GC=_JHC_GC_JGC'";
char jhc_command[] = "jhc -fffi -C -o hs_main.c hs_src/Main.hs";
char jhc_version[] = "jhc 0.8.1 (-0)";

#include "jhc_rts_header.h"
static struct s_cache *cCJhc_Type_Word_Word32;
static struct s_cache *cFtheMain$d2;
#include <c_extern.h>

enum {
    CJhc_Prim_Prim_$BE = 1,
    CJhc_Prim_Prim_$LR = 0,
    CJhc_Prim_Prim_$x3a = 0,
    CJhc_Type_Word_Word32 = 0
};
struct sCJhc_Prim_Prim_$x3a A_ALIGNED;
struct sCJhc_Type_Word_Word32 A_ALIGNED;
struct sFtheMain$d2 A_ALIGNED;

struct sCJhc_Prim_Prim_$x3a {
    sptr_t a1;
    sptr_t a2;
};

struct sCJhc_Type_Word_Word32 {
    uint32_t a1;
};

struct sFtheMain$d2 {
    fptr_t head;
    sptr_t a1;
    sptr_t a2;
};
void jhc_hs_init(void) ;
static wptr_t E__ftheMain$d2(gc_t gc,struct sFtheMain$d2* arg) A_STD A_FALIGNED;
void _amain(void) ;
static void b__main(gc_t gc) A_STD;
static wptr_t fMain_gpioOut(gc_t gc,wptr_t v148115987) A_STD A_MALLOC;
static void ftheMain(gc_t gc) A_STD;
static wptr_t ftheMain$d2(gc_t gc,sptr_t v128,sptr_t v264254028) A_STD A_MALLOC;
/* CAFS */
/* (HcNode CJhc.Type.Word.Word32 [Left 0],1) */
static const struct sCJhc_Type_Word_Word32 _c1 = {.a1 = 0};
#define c1 (TO_SPTR_C(P_WHNF, (sptr_t)&_c1))
/* (HcNode CJhc.Type.Word.Word32 [Left Op {primCOp = BinOp Shl bits32 bits32, primRetTy = bits32}(1,13)],2) */
static const struct sCJhc_Type_Word_Word32 _c2 = {.a1 = 1 << 13};
#define c2 (TO_SPTR_C(P_WHNF, (sptr_t)&_c2))
/* (HcNode CJhc.Type.Word.Word32 [Left Op {primCOp = BinOp Shl bits32 bits32, primRetTy = bits32}(1,15)],4) */
static const struct sCJhc_Type_Word_Word32 _c4 = {.a1 = 1 << 15};
#define c4 (TO_SPTR_C(P_WHNF, (sptr_t)&_c4))
/* (HcNode CJhc.Prim.Prim.: [Right 2,Left &("CJhc.Prim.Prim.[]")],3) */
static const struct sCJhc_Prim_Prim_$x3a _c3 = {.a1 = c2, .a2 = (sptr_t)SET_RAW_TAG(CJhc_Prim_Prim_$BE)};
#define c3 (TO_SPTR_C(P_WHNF, (sptr_t)&_c3))
/* (HcNode CJhc.Prim.Prim.: [Right 4,Left &("CJhc.Prim.Prim.[]")],5) */
static const struct sCJhc_Prim_Prim_$x3a _c5 = {.a1 = c4, .a2 = (sptr_t)SET_RAW_TAG(CJhc_Prim_Prim_$BE)};
#define c5 (TO_SPTR_C(P_WHNF, (sptr_t)&_c5))
/* (HcNode CJhc.Prim.Prim.: [Right 2,Right 5],6) */
static const struct sCJhc_Prim_Prim_$x3a _c6 = {.a1 = c2, .a2 = c5};
#define c6 (TO_SPTR_C(P_WHNF, (sptr_t)&_c6))

const void * const nh_stuff[] = {
&_c1, &_c2, &_c3, &_c4, &_c5, &_c6, NULL
};


void 
jhc_hs_init(void)
{
        find_cache(&cCJhc_Type_Word_Word32,arena,TO_BLOCKS(sizeof(struct sCJhc_Type_Word_Word32)),0);
        find_cache(&cFtheMain$d2,arena,TO_BLOCKS(sizeof(struct sFtheMain$d2)),3);
}

static wptr_t A_STD A_FALIGNED
E__ftheMain$d2(gc_t gc,struct sFtheMain$d2* arg)
{
        {   wptr_t r;
            gc_frame0(gc,1,MKLAZY(arg));
            r = ftheMain$d2(gc,arg->a1,arg->a2);
            update(arg,r);
            return r;
        }
}

void 
_amain(void)
{
        return (void)b__main(saved_gc);
}

static void A_STD
b__main(gc_t gc)
{
        return ftheMain(gc);
}

static wptr_t A_STD A_MALLOC
fMain_gpioOut(gc_t gc,wptr_t v148115987)
{
        wptr_t v100000;
        sptr_t v124940224;
        sptr_t v44725398;
        uint32_t v256943490;
        sptr_t v148116003 = demote(v148115987);
        v124940224 = c1;
        v44725398 = v148116003;
        fR$__fJhc_Basics_foldl__2:;
        {   {   gc_frame0(gc,1,v124940224);
                wptr_t v100002 = eval(gc,v44725398);
		/* xxx ok! */
                if (SET_RAW_TAG(CJhc_Prim_Prim_$BE) == v100002) {
		    /* xxx ok! */
                    v100000 = eval(gc,v124940224);
		    /* xxx not reach */
                } else {
                    sptr_t v110947982;
                    sptr_t v130;
                    /* ("CJhc.Prim.Prim.:" ni110947982 ni130) */
                    v110947982 = ((struct sCJhc_Prim_Prim_$x3a*)v100002)->a1;
                    v130 = ((struct sCJhc_Prim_Prim_$x3a*)v100002)->a2;
                    {   gc_frame0(gc,2,v130,v110947982);
                        sptr_t x3 = s_alloc(gc,cFtheMain$d2);
			/* xxx ok! */
                        ((struct sFtheMain$d2*)x3)->head = TO_FPTR(&E__ftheMain$d2);
                        ((struct sFtheMain$d2*)x3)->a1 = v110947982;
                        ((struct sFtheMain$d2*)x3)->a2 = v124940224;
                        sptr_t v111357766 = MKLAZY(x3);
                        v124940224 = v111357766;
                        v44725398 = v130;
                        goto fR$__fJhc_Basics_foldl__2;
                    }
                }
            }
        }
	/* xxx not reach */
        v256943490 = ((struct sCJhc_Type_Word_Word32*)v100000)->a1;
        *((volatile uint32_t *)(1073809420)) = v256943490;
        saved_gc = gc;
        (void)Delay((uint32_t)500000);
        return SET_RAW_TAG(CJhc_Prim_Prim_$LR);
}

static void A_STD
ftheMain(gc_t gc)
{
        fR$__fControl_Monad_forever__5:;
        {
	    fMain_gpioOut(gc,PROMOTE(c3));
	    /* xxx not reach */
            fMain_gpioOut(gc,PROMOTE(c6));
            fMain_gpioOut(gc,PROMOTE(c5));
            fMain_gpioOut(gc,SET_RAW_TAG(CJhc_Prim_Prim_$BE));
            goto fR$__fControl_Monad_forever__5;
        }
        return;
}

static wptr_t A_STD A_MALLOC
ftheMain$d2(gc_t gc,sptr_t v128,sptr_t v264254028)
{
        {   gc_frame0(gc,1,v128);
            wptr_t v100004 = eval(gc,v264254028);
            {   uint32_t v119285244;
                uint32_t v29375122;
                gc_frame0(gc,1,v100004);
                wptr_t v100006 = eval(gc,v128);
                v119285244 = ((struct sCJhc_Type_Word_Word32*)v100004)->a1;
                v29375122 = ((struct sCJhc_Type_Word_Word32*)v100006)->a1;
                uint32_t v44000678 = (v119285244 | v29375122);
                wptr_t x4 = s_alloc(gc,cCJhc_Type_Word_Word32);
                ((struct sCJhc_Type_Word_Word32*)x4)->a1 = v44000678;
                return x4;
            }
        }
}

Main.hs

import Data.Word
import Data.Bits
import Control.Monad
import Foreign.Ptr
import Foreign.Storable

foreign import ccall "c_extern.h Delay" c_delay :: Word32 -> IO ()

gpioPtr :: Ptr Word32
gpioPtr = odr
  where periphBase     = nullPtr        `plusPtr` 0x40000000
        arb2periphBase = periphBase     `plusPtr` 0x10000
        gpioaBase      = arb2periphBase `plusPtr` 0x0800
        odr            = gpioaBase      `plusPtr` 12

gpioOut :: [Word32] -> IO ()
gpioOut v = do
  let v' = foldl (.|.) 0 v
  poke gpioPtr v'
  c_delay 500000

main :: IO ()
main = forever $ do
  gpioOut [1 `shiftL` 13]
  gpioOut [1 `shiftL` 13, 1 `shiftL` 15]
  gpioOut [1 `shiftL` 15]
  gpioOut []