A.cmm

#include <Cmm.h>

getInfoTable (P_ a)
{
  W_ clos, info, type;
  clos = UNTAG(a);
  info = %GET_STD_INFO(clos);
  return (info);
}

getInfoTableST (P_ a, W_ st)
{
  W_ clos, info, type;
  clos = UNTAG(a);
  info = %GET_STD_INFO(clos);
  return (st, info);
}

allocateByInfoTable (W_ info)
{
  W_ bytes, ptrs, nptrs;

  ptrs = TO_W_(%INFO_PTRS(info));
  nptrs = TO_W_(%INFO_NPTRS(info));
  bytes = SIZEOF_StgHeader + WDS(ptrs) + WDS(nptrs);

  HP_CHK_GEN(bytes);

  P_ val;
  val = Hp + WDS(1);
  Hp = Hp + bytes;

  SET_HDR(val, info+SIZEOF_StgInfoTable, CCCS);

  W_ i;
  i = 0;

loop1:
  if (i < ptrs)
  {
    StgClosure_payload(val, i) = base_GHCziErr_undefined_closure;
    i = i + 1;
    goto loop1;
  }

loop2:
  if (i < (ptrs + nptrs))
  {
    StgClosure_payload(val, i) = 0;
    i = i + 1;
    goto loop2;
  }

  return (val, ptrs, nptrs);
}
allocateByInfoTableST (W_ info, W_ st)
{
  W_ bytes, ptrs, nptrs;

  ptrs = TO_W_(%INFO_PTRS(info));
  nptrs = TO_W_(%INFO_NPTRS(info));
  bytes = SIZEOF_StgHeader + WDS(ptrs) + WDS(nptrs);

  HP_CHK_GEN(bytes);

  P_ val;
  val = Hp + WDS(1);
  Hp = Hp + bytes;

  SET_HDR(val, info+SIZEOF_StgInfoTable, CCCS);

  W_ i;
  i = 0;

loop1:
  if (i < ptrs)
  {
    StgClosure_payload(val, i) = base_GHCziErr_undefined_closure;
    i = i + 1;
    goto loop1;
  }

loop2:
  if (i < (ptrs + nptrs))
  {
    StgClosure_payload(val, i) = 0;
    i = i + 1;
    goto loop2;
  }

  return (st, val, ptrs, nptrs);
}

B.hs

{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples  #-}
{-# LANGUAGE UnliftedFFITypes #-}

module Main where

import Control.Monad.ST
import GHC.Prim
import GHC.Ptr
import GHC.ST
import GHC.Word
import Text.Printf

data InfoTable

foreign import prim "getInfoTable" getInfoTablePrim :: Any -> Addr#
foreign import prim "getInfoTableST" getInfoTablePrimST :: Any -> State# s -> (# State# s, Addr# #)

getInfoTable :: a -> Ptr InfoTable
getInfoTable val = Ptr (getInfoTablePrim (unsafeCoerce# val))

getInfoTableST :: a -> ST s (Ptr InfoTable)
getInfoTableST val = ST $ \st -> case getInfoTablePrimST (unsafeCoerce# val) st of
  (# st', itable #) -> (# st', Ptr itable #)


foreign import prim "allocateByInfoTable" allocateByInfoTablePrim :: Addr# -> (# Addr#, Word#, Word# #)
foreign import prim "allocateByInfoTableST" allocateByInfoTablePrimST :: Addr# -> State# s -> (# State# s, Addr#, Word#, Word# #)

allocateByInfoTable :: Ptr InfoTable -> (a, Word, Word)
allocateByInfoTable (Ptr itable) = case allocateByInfoTablePrim itable of
  (# closure, ptrs, nptrs #) -> (unsafeCoerce# closure, W# ptrs, W# nptrs)

allocateByInfoTableST :: Ptr InfoTable -> ST s (a, Word, Word)
allocateByInfoTableST (Ptr itable) = ST $ \st -> case allocateByInfoTablePrimST itable st of
  (# st', closure, ptrs, nptrs #) -> (# st', (unsafeCoerce# closure, W# ptrs, W# nptrs) #)


data Foo = Foo deriving Show

main :: IO ()
main = do
  do putStrLn "Regular Primops"
     let itable = getInfoTable Foo
         (val, ptrs, nptrs) = allocateByInfoTable itable

     printf "Infotable: %s\n" (show itable)
     printf "Value    : %s\n" (show (val :: Foo))
     printf "Ptrs     : %u\n" ptrs
     printf "NPtrs    : %u\n" nptrs

  putStrLn ""

  do putStrLn "ST Primops"
     itable <- stToIO $ getInfoTableST Foo
     printf "Infotable: %s\n" (show itable)
     (val, ptrs, nptrs) <- stToIO $ allocateByInfoTableST itable
     printf "Value    : %s\n" (show (val :: Foo))
     printf "Ptrs     : %u\n" ptrs
     printf "NPtrs    : %u\n" nptrs

Regular Primops
Infotable: 0x00000001059ed308
Value    : Foo
Ptrs     : 0
NPtrs    : 4391910776

ST Primops
Infotable: 0x000000010610f419
B: internal error: allocation of -11539778160 bytes too large (GHC should have complained at compile-time)
    (GHC version 7.7.20130810 for x86_64_apple_darwin)
    Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug
Abort trap: 6