Skip to content

Instantly share code, notes, and snippets.

@NathanHowell

NathanHowell/A.cmm

Last active Dec 21, 2015
Embed
What would you like to do?
#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);
}
{-# 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
@NathanHowell

This comment has been minimized.

Copy link
Owner Author

@NathanHowell NathanHowell commented Aug 29, 2013

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.