| | 5 | == The qsort_b example using a foreign wrapper == |
| | 6 | |
| | 7 | The most straight-forward approach is to use the existing FFI support for turning Haskell functions into C function pointers by way of a foreign import wrapper declaration. We can then embed these C function pointers in block literals without the need for a explicit environment on the C side. |
| | 8 | |
| | 9 | === Block literals === |
| | 10 | |
| | 11 | Blocks are by default allocated on the stack in C and only promoted to the heap using an explicity `Block_copy()` function. In Haskell, we always allocate them on the heap, which is indicated by the pointer being placed in a block literals `isa` field: |
| | 12 | {{{ |
| | 13 | foreign import ccall "& _NSConcreteGlobalBlock" nsConcreteGlobalBlock :: Ptr () |
| | 14 | }}} |
| | 15 | |
| | 16 | A block literal with an empty environment has the following layout: |
| | 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 | |
| | 26 | long, quad :: Int |
| | 27 | long = 4 -- long word = 32 bit |
| | 28 | quad = 8 -- quad word = 64 bit |
| | 29 | |
| | 30 | isaOffset, flagsOffset, invokeOffset, descriptorOffset, blockLiteralSize :: Int |
| | 31 | isaOffset = 0 |
| | 32 | flagsOffset = isaOffset + quad |
| | 33 | invokeOffset = flagsOffset + long + long |
| | 34 | descriptorOffset = invokeOffset + quad |
| | 35 | blockLiteralSize = descriptorOffset + quad |
| | 36 | }}} |
| | 37 | |
| | 38 | In Haskell, we represent block literals as opaque pointers: |
| | 39 | {{{ |
| | 40 | newtype Block a = Block (Ptr (Block a)) |
| | 41 | }}} |
| | 42 | |
| | 43 | |
| | 44 | When turning a Haskell function into a C function pointer to be included in a block literal as the `invoke` function, we need to take care to add a pointer to the block literal itself as a new first argument: |
| | 45 | {{{ |
| | 46 | mkBlock :: ((Block f -> f) -> IO (FunPtr (Block f -> f))) -> f -> IO (Block f) |
| | 47 | mkBlock mkWrapper f |
| | 48 | = do { fPtr <- mkWrapper (const f) |
| | 49 | ; blockPtr <- mallocBytes blockLiteralSize |
| | 50 | ; poke (blockPtr `plusPtr` isaOffset) nsConcreteGlobalBlock |
| | 51 | ; poke (blockPtr `plusPtr` flagsOffset) (0x50000000 :: Word32) |
| | 52 | ; poke (blockPtr `plusPtr` invokeOffset) fPtr |
| | 53 | ; poke (blockPtr `plusPtr` descriptorOffset) descriptorPtr |
| | 54 | ; return $ Block blockPtr |
| | 55 | } |
| | 56 | }}} |
| | 57 | |
| | 58 | The block descriptor is static, except for the signature that we omit for the moment. |
| | 59 | {{{ |
| | 60 | -- Block descriptor structure shared between all blocks. |
| | 61 | -- |
| | 62 | -- .quad 0 # unsigned long int reserved; |
| | 63 | -- .quad 32 # unsigned long int size = blockLiteralSize; |
| | 64 | -- .quad signature_str # const char *signature; |
| | 65 | -- .quad 0 # <undocumented> |
| | 66 | |
| | 67 | descriptorPtr :: Ptr () |
| | 68 | descriptorPtr |
| | 69 | = unsafePerformIO $ |
| | 70 | do { descPtr <- mallocBytes (4 * quad) |
| | 71 | ; poke (descPtr `plusPtr` (0 * quad)) (0 :: Word64) |
| | 72 | ; poke (descPtr `plusPtr` (1 * quad)) blockLiteralSizeWord64 |
| | 73 | ; poke (descPtr `plusPtr` (2 * quad)) nullPtr -- gcc puts a NULL in; should be ok for now |
| | 74 | ; poke (descPtr `plusPtr` (3 * quad)) (0 :: Word64) |
| | 75 | ; return descPtr |
| | 76 | } |
| | 77 | where |
| | 78 | blockLiteralSizeWord64 :: Word64 |
| | 79 | blockLiteralSizeWord64 = fromIntegral blockLiteralSize |
| | 80 | }}} |
