#include "haskell2c.h" #ifdef PROFILE static SInfo mkpackProfInfo = {"Pack","Pack.mkPacked","Prelude.Packed a"}; static SInfo rdpackProfInfo = {"Pack","Pack.rdPacked","Prelude.Int"}; static SInfo szpackProfInfo = {"Pack","Pack.sizePacked","Prelude.Int"}; static SInfo jnpackProfInfo = {"Pack","Pack.joinPacked","Prelude.Packed a"}; static SInfo offsetProfInfo = {"Pack","Pack.offset","Prelude.Packed a"}; #endif /*#define WORDSIZE 32 /*(sizeof(unsigned)*8)*/ #define mask(x) (unsigned)((unsigned)(0xffffffff)>>(WORDSIZE-x)) /* ------------------------------------------------------------------- ------------------------------------------------------------------- */ /* mkPacked :: Int -> Int -> Packed a */ C_HEADER(mkPacked) { unsigned size, tmp, value; NodePtr nodeptr, nretVal; /* collect arguments */ nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); size = (unsigned)GET_INT_VALUE(nodeptr); nodeptr = C_GETARG1(2); IND_REMOVE(nodeptr); value = (unsigned)GET_INT_VALUE(nodeptr); size &= mask(16); /* truncate size to fit storage field */ value &= mask((size>32?32:size)); /* truncate value to required size */ /* construct return value */ if (size<=8) { value |= (size << 8); nretVal = C_ALLOC(1+EXTRA); nretVal[0] = CONSTR(value,0,0); } else { tmp = (size+31)/32; nretVal = C_ALLOC(1+EXTRA+2); nretVal[0] = CONSTR(0,2,1); nretVal[1+EXTRA] = C_ALLOC(1+EXTRA+tmp); nretVal[1+EXTRA][0] = CONSTRW(tmp,0) for (int i=0; i Packed a -> Int */ C_HEADER(rdPacked) { unsigned start, size, tmp, tmpsize, tmpval, wordpos, bitpos; unsigned value=0; NodePtr nodeptr, nretVal; nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); size = (unsigned)GET_INT_VALUE(nodeptr); if (size==0) { /*fprintf (stderr,"rdPacked 0\n");*/ value = 0; } else { nodeptr = C_GETARG1(2); IND_REMOVE(nodeptr); if (CONINFO_SIZE(GET_CONINFO(nodeptr)) == 1+EXTRA) { tmp = GET_CONSTR(nodeptr); tmpsize = tmp >> 8; tmpval = tmp & mask(8); if (size>tmpsize) size=tmpsize; value = tmpval >> (tmpsize-size); } else { NodePtr ptr = GET_POINTER_ARG1(nodeptr,1); tmp = GET_VALUE_ARG1(nodeptr,2); tmpsize = tmp & mask(16); if (size>tmpsize) size=tmpsize; start = tmp >> 16; value = getval(ptr,start,size); } } nretVal = nhc_mkInt(value); INIT_PROFINFO(nretVal,&rdpackProfInfo); C_RETURN(nretVal); } unsigned getval (ptr, start, size) NodePtr ptr; unsigned start, size; { unsigned wordpos, bitpos, value; wordpos = (start+31)/32; bitpos = start % 32; if (bitpos + size > 32) { value = (ptr[1+EXTRA+wordpos] & mask(32-bitpos)) << (bitpos+size-32); value |= (ptr[1+EXTRA+wordpos+1] >> (64-size-bitpos)) & mask(bitpos+size-32); } else { value = (ptr[1+EXTRA+wordpos] >> (32-bitpos-size)) & mask(size); } return value; } /* joinPacked :: Packed a -> Packed b -> Packed c */ C_HEADER(joinPacked) { NodePtr nodeptr1, nodeptr2, nretVal; unsigned tmp, size, value; unsigned start1, start2, size1, size2, value1, value2; nodeptr1 = C_GETARG1(1); IND_REMOVE(nodeptr1); if (CONINFO_SIZE(GET_CONINFO(nodeptr1)) == 1+EXTRA) { tmp = GET_CONSTR(nodeptr1); size1 = tmp>>8; value1 = tmp&mask(size1); } else { tmp = GET_VALUE_ARG1(nodeptr1,2); size1 = tmp&mask(16); start1 = tmp>>16; if (size1 <= 32) { value1 = getval(GET_POINTER_ARG1(nodeptr1,1),start1,size1); } } nodeptr2 = C_GETARG1(2); IND_REMOVE(nodeptr2); if (CONINFO_SIZE(GET_CONINFO(nodeptr2)) == 1+EXTRA) { tmp = GET_CONSTR(nodeptr2); size2 = tmp>>8; value2 = tmp&mask(size2); } else { tmp = GET_VALUE_ARG1(nodeptr2,2); size2 = tmp&mask(16); start2 = tmp>>16; if (size2 <= 32) { value2 = getval(GET_POINTER_ARG1(nodeptr2,1),start2,size2); } } size = size1+size2; if (size <= 8) { value = value2 | (value1 << size2); value |= (size << 8); nretVal = C_ALLOC(1+EXTRA); nretVal[0] = CONSTR(value,0,0); } else if (size <= 32) { value = value2 | (value1 << size2); nretVal = C_ALLOC(1+EXTRA+2); nretVal[0] = CONSTR(0,2,1); nretVal[1+EXTRA] = C_ALLOC(1+EXTRA+1); nretVal[1+EXTRA][0] = CONSTRW(1,0) nretVal[1+EXTRA][1+EXTRA] = value; nretVal[2+EXTRA] = ((32-size) << 16) | size; } else { tmp = (size+31)/32; nretVal = C_ALLOC(1+EXTRA+2); nretVal[0] = CONSTR(0,2,1); nretVal[1+EXTRA] = C_ALLOC(1+EXTRA+tmp); nretVal[1+EXTRA][0] = CONSTRW(tmp,0) for (int i=0; i Int */ C_HEADER(sizePacked) { unsigned tmp; NodePtr nodeptr, nretVal; nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); if (CONINFO_SIZE(GET_CONINFO(nodeptr)) == 1+EXTRA) { tmp = GET_CONSTR(nodeptr); nretVal = nhc_mkInt(tmp>>8); } else { tmp = GET_VALUE_ARG1(nodeptr,2); nretVal = nhc_mkInt(tmp&mask(16)); } INIT_PROFINFO(nretVal,&szpackProfInfo); C_RETURN(nretVal); } /* offset :: Int -> Packed a -> Packed b */ C_HEADER(offset) { NodePtr nodeptr, nretVal; unsigned tmp, add, size; nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); add = (unsigned)GET_INT_VALUE(nodeptr); nodeptr = C_GETARG1(2); IND_REMOVE(nodeptr); if (CONINFO_SIZE(GET_CONINFO(nodeptr)) == 1+EXTRA) { unsigned value; tmp = GET_CONSTR(nodeptr); size = (tmp>>8); size = (add>=size ? 0 : size-add); value = (tmp & mask(size)) | (size<<8); nretVal = C_ALLOC(1+EXTRA) nretVal[0] = CONSTR(value,0,0); } else { tmp = GET_VALUE_ARG1(nodeptr,2); size = (tmp & mask(16)); if (add>=size) { nretVal = C_ALLOC(1+EXTRA) nretVal[0] = CONSTR(0,0,0); } else { unsigned start; start = (tmp & ~(mask(16))) + (add<<16); size -= add; nretVal = C_ALLOC(1+EXTRA+2) nretVal[0] = CONSTR(0,2,1); nretVal[1+EXTRA] = GET_POINTER_ARG1(nodeptr,1); nretVal[2+EXTRA] = (start | size); } } INIT_PROFINFO(nretVal,&offsetProfInfo); C_RETURN(nretVal); } /* primAlignPackedLo :: Packed a -> Packed a */ /* primAlignPackedHi :: Packed a -> Packed a */ C_HEADER(primAlignPackedLo) { unsigned tmp; NodePtr nodeptr, nretVal; nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); if (CONINFO_SIZE(GET_CONINFO(nodeptr)) == 1+EXTRA) { tmp = GET_CONSTR(nodeptr); tmp &= mask(8); tmp |= 8<<8; nretVal = C_ALLOC(1+EXTRA); nretVal[0] = CONSTR(tmp,0,0); INIT_PROFINFO(nretVal,&packProfInfo); } else { tmp = GET_VALUE_ARG1(nodeptr,2); nretVal = C_ALLOC(1+EXTRA+2); nretVal[0] = CONSTR(0,2,1); nretVal[1+EXTRA] = GET_POINTER_ARG1(nodeptr,1); nretVal[2+EXTRA] = (tmp...) | (tmp & mask(16)); } C_RETURN(nretVal); } /* primPutPacked :: Handle -> Packed a -> Int */ /* -- Assumes that Packed a is aligned. */ C_HEADER(primPutPacked) { int n, err; unsigned ptr; short offset=0; FileDesc *a; NodePtr nodeptr; nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); UPDATE_PROFINFO(nodeptr) a = derefForeignObj((ForeignObj*)(GET_INT_VALUE(nodeptr))); nodeptr = C_GETARG1(3); IND_REMOVE(nodeptr); ptr = (unsigned)GET_INT_VALUE(nodeptr); offset = (ptr & IdxMask) >>3; /* alignment=> idx `elem` [0,8,16,24] */ ptr = ptr >> PtrShift; err = fwrite((char*)(&binSpace[ptr])+offset, 1, n, a->fp); C_RETURN(nhc_mkInt(err)); } /* primGetPacked :: Handle -> Packed a */ C_HEADER(primGetNBytes) { unsigned r; FileDesc *a; NodePtr nodeptr, nretVal; nodeptr = C_GETARG1(1); IND_REMOVE(nodeptr); UPDATE_PROFINFO(nodeptr) a = derefForeignObj((ForeignObj*)(GET_INT_VALUE(nodeptr))); err = fread((char*)&r, sizeof(int), 1, a->fp); err = fread((char*)(&binSpace[binPtr])+offset, 1, n, a->fp); ptr = (binPtr << PtrShift) | ((unsigned)bitIdx & IdxMask); /* calculate new internal position in binspace */ binPtr += (offset+err) /4; bitIdx = ((offset+err)%4) <<3; C_RETURN(nhc_mkInt(ptr)); }