BlockObjects/FakingIt: QSortB_wrapper.hs

File QSortB_wrapper.hs, 4.8 KB (added by chak, 3 years ago)

Quicksort example using a foreign import wrapper

Line 
1-- Simple use of blocks, where we use a dynamically exported Haskell function as the block function
2--
3-- The specification at <http://clang.llvm.org/docs/Block-ABI-Apple.txt> is a bit vague, possibly
4-- somewhat outdated, and claims it only applies to the 32-bit runtime.  So, I used the assembly
5-- produced by clang on OS X 10.7 to get definite layout information.
6
7import Data.List
8import Data.Word
9import Foreign
10import Foreign.C
11
12
13-- Blocks in Haskell
14-- -----------------
15
16foreign import ccall "& _NSConcreteGlobalBlock" nsConcreteGlobalBlock :: Ptr ()
17
18-- Layout of the block literal (64-bit runtime)
19--
20-- .quad        __NSConcreteGlobalBlock           # void *isa;
21-- .long        1342177280                        # int  flags = 0x50000000;
22-- .long        0                                 # int  reserved;
23-- .quad        ___block_invoke                   # void (*invoke)(void *, ...);
24-- .quad        ___block_descriptor               # struct Block_descriptor *descriptor;
25
26long, quad :: Int
27long = 4  -- long word = 32 bit
28quad = 8  -- quad word = 64 bit
29
30isaOffset, flagsOffset, invokeOffset, descriptorOffset, blockLiteralSize :: Int
31isaOffset        = 0
32flagsOffset      = isaOffset        + quad
33invokeOffset     = flagsOffset      + long + long
34descriptorOffset = invokeOffset     + quad
35blockLiteralSize = descriptorOffset + quad
36
37newtype Block a = Block (Ptr (Block a))
38
39mkBlock :: ((Block f -> f) -> IO (FunPtr (Block f -> f))) -> f -> IO (Block f)
40mkBlock mkWrapper f
41  = do { fPtr     <- mkWrapper (const f)
42       ; blockPtr <- mallocBytes blockLiteralSize
43       ; poke (blockPtr `plusPtr` isaOffset)        nsConcreteGlobalBlock
44       ; poke (blockPtr `plusPtr` flagsOffset)      (0x50000000 :: Word32)
45       ; poke (blockPtr `plusPtr` invokeOffset)     fPtr
46       ; poke (blockPtr `plusPtr` descriptorOffset) descriptorPtr
47       ; return $ Block blockPtr
48       }
49
50-- Block descriptor structure shared between all blocks.
51--
52-- .quad        0                                 # unsigned long int reserved;
53-- .quad        32                                # unsigned long int size = blockLiteralSize;
54-- .quad        signature_str                     # const char *signature;
55-- .quad        0                                 # <undocumented>
56
57descriptorPtr :: Ptr ()
58descriptorPtr
59  = unsafePerformIO $ 
60    do { descPtr <- mallocBytes (4 * quad)
61       ; poke (descPtr `plusPtr` (0 * quad)) (0 :: Word64)
62       ; poke (descPtr `plusPtr` (1 * quad)) blockLiteralSizeWord64
63       ; poke (descPtr `plusPtr` (2 * quad)) nullPtr    -- gcc puts a NULL in; should be ok for now
64       ; poke (descPtr `plusPtr` (3 * quad)) (0 :: Word64)
65       ; return descPtr
66       }
67  where
68    blockLiteralSizeWord64 :: Word64
69    blockLiteralSizeWord64 = fromIntegral blockLiteralSize
70
71
72-- Using a Haskell function wrapper as the block invoke function
73-- -------------------------------------------------------------
74
75-- The comparison function passed to 'qsort_b', gets pointers to the array elements it is to
76-- compare.  As these array elements are marshalled Haskell thunks, they are themselves *stable*
77-- pointers to the actual values that ought to be compared.
78--
79type CmpFun a = Ptr (StablePtr a) -> Ptr (StablePtr a) -> IO Int
80
81foreign import ccall "wrapper" mkCmpWrapper
82  :: (Block (CmpFun a) -> CmpFun a) -> IO (FunPtr (Block (CmpFun a) -> CmpFun a))
83
84mkCmpBlock :: CmpFun a -> IO (Block (CmpFun a))
85mkCmpBlock = mkBlock mkCmpWrapper
86
87
88-- Application code
89-- ----------------
90
91myCharacters = ["TomJohn", "George", "Charles Condomine"]
92
93fromOrdering :: Ordering -> Int
94fromOrdering LT = -1
95fromOrdering EQ = 0
96fromOrdering GT = 1
97
98foreign import ccall "stdlib.h" qsort_b
99  :: Ptr (StablePtr a) -> CSize -> CSize -> Block (CmpFun a) -> IO ()
100
101main :: IO ()
102main
103  = do {   -- convert a list of strings into a C array of stable pointers to those strings in the
104           -- Haskell heap
105       ; ptrs <- mapM newStablePtr myCharacters
106       ; sortedPtrs <- withArray ptrs $ \myCharactersArray -> do
107           {
108               -- get the size in bytes of a stable pointer to a Haskell string
109           ; let elemSize = fromIntegral $ sizeOf (undefined :: StablePtr String)
110
111               -- invoke C land 'qsort_b' with a Haskell comparison function passed as a block
112               -- object; mutates 'myCharactersArray'
113           ; cmpBlock <- mkCmpBlock $ \lPtr rPtr -> do 
114               { l <- deRefStablePtr =<< peek lPtr
115               ; r <- deRefStablePtr =<< peek rPtr
116               ; return $ fromOrdering (l `compare` r)
117               }
118           ; qsort_b myCharactersArray (genericLength myCharacters) elemSize cmpBlock
119
120           ; peekArray (length ptrs) myCharactersArray
121           }
122
123          -- turn the array of Haskell strings back into a list of strings
124       ; mySortedCharacters <- mapM deRefStablePtr sortedPtrs
125     
126       ; print mySortedCharacters
127       }