primal-0.3.0.0: cbits/primal_stg.cmm

/* Copied from ghc for backwards compatibility:
 * https://gitlab.haskell.org/ghc/ghc/-/blob/6d172e63f3dd3590b0a57371efb8f924f1fcdf05/libraries/base/cbits/CastFloatWord.cmm
*/
#include "Cmm.h"
#include "MachDeps.h"

#if WORD_SIZE_IN_BITS == 64
#define DOUBLE_SIZE_WDS   1
#else
#define DOUBLE_SIZE_WDS   2
#endif

#if SIZEOF_W == 4
#define TO_ZXW_(x) %zx32(x)
#elif SIZEOF_W == 8
#define TO_ZXW_(x) %zx64(x)
#endif

// macro was changed in ghc-9
#ifndef OVERWRITING_CLOSURE_OFS
#define OVERWRITING_CLOSURE_OFS(c,n) OVERWRITING_CLOSURE_MUTABLE(c,n)
#endif

primal_stg_word64ToDoublezh(I64 w)
{
    D_ d;
    P_ ptr;

    STK_CHK_GEN_N (DOUBLE_SIZE_WDS);

    reserve DOUBLE_SIZE_WDS = ptr {
        I64[ptr] = w;
        d = D_[ptr];
    }

    return (d);
}

primal_stg_doubleToWord64zh(D_ d)
{
    I64 w;
    P_ ptr;

    STK_CHK_GEN_N (DOUBLE_SIZE_WDS);

    reserve DOUBLE_SIZE_WDS = ptr {
        D_[ptr] = d;
        w = I64[ptr];
    }

    return (w);
}

primal_stg_word32ToFloatzh(W_ w)
{
    F_ f;
    P_ ptr;

    STK_CHK_GEN_N (1);

    reserve 1 = ptr {
        I32[ptr] = %lobits32(w);
        f = F_[ptr];
    }

    return (f);
}

primal_stg_floatToWord32zh(F_ f)
{
    W_ w;
    P_ ptr;

    STK_CHK_GEN_N (1);

    reserve 1 = ptr {
        F_[ptr] = f;
        // Fix #16617: use zero-extending (TO_ZXW_) here
        w = TO_ZXW_(I32[ptr]);
    }

    return (w);
}


// shrink size of MutableArray in-place
primal_stg_shrinkMutableArrayzh ( gcptr arr, W_ new_size )
// MutableArray# s a -> Int# -> State# s -> State# s
{
   ASSERT(new_size <= StgMutArrPtrs_ptrs(mba));


   OVERWRITING_CLOSURE_OFS(arr, (BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) +
                                 new_size));
   StgMutArrPtrs_ptrs(arr) = new_size;

   return (new_size);
}


// shrink size of SmallMutableArray in-place
primal_stg_shrinkSmallMutableArrayzh ( gcptr arr, W_ new_size )
// SmallMutableArray# s a -> Int# -> State# s -> State# s
{
   ASSERT(new_size <= StgSmallMutArrPtrs_ptrs(arr));

   OVERWRITING_CLOSURE_OFS(arr, (BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) +
                                 new_size));
   StgSmallMutArrPtrs_ptrs(arr) = new_size;

   return (new_size);
}