diff --git a/CrossCodegen.hs b/CrossCodegen.hs index 06c3911..429a77f 100644 --- a/CrossCodegen.hs +++ b/CrossCodegen.hs @@ -226,6 +226,15 @@ outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _) ke (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False "poke" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") >> return False + "readByteArray" -> outputByteArrayOperation True "readByteArray" + "writeByteArray" -> outputByteArrayOperation True "writeByteArray" + "indexByteArray" -> outputByteArrayOperation True "indexByteArray" + "readByteArrayHash" -> outputByteArrayOperation False "readByteArray#" + "writeByteArrayHash" -> outputByteArrayOperation False "writeByteArray#" + "indexByteArrayHash" -> outputByteArrayOperation False "indexByteArray#" + "readOffAddrHash" -> outputByteArrayOperation False "readOffAddr#" + "writeOffAddrHash" -> outputByteArrayOperation False "writeOffAddr#" + "indexOffAddrHash" -> outputByteArrayOperation False "indexOffAddr#" "ptr" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") >> return False "type" -> computeType z >>= output >> return False @@ -236,7 +245,28 @@ outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _) ke "define" -> return True "undef" -> return True _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode") - where outputConst value' formatter = computeConst z value' >>= (output . formatter) + where + outputConst value' formatter = computeConst z value' >>= (output . formatter) + -- GHC's ByteArray# type only supports read/write/index in an aligned + -- fashion. The index is always given in elements, not bytes. So, we + -- must divide the field's offset in bytes by its size to get index in + -- terms of elements. + outputByteArrayOperation boxed operation = case break (== ',') value of + (typ,',':field) -> do + byteOffset <- computeConst z ("offsetof(" ++ value ++ ")") + typSize <- computeConst z ("sizeof(" ++ typ ++ ")") + -- This is the FIELD_SIZEOF macro as defined in the linux kernel. + fieldSize <- computeConst z ("sizeof(((" ++ typ ++ "*)0)->" ++ field ++ ")") + when (not (isPowerOfTwo fieldSize)) (testFail pos ("#error " ++ value)) + let (elemOffset,r1) = divMod byteOffset fieldSize + when (r1 /= 0) (testFail pos ("#error " ++ value)) + let (typFieldRatio,r2) = divMod typSize fieldSize + when (r2 /= 0) (testFail pos ("#error " ++ value)) + if boxed + then output ("(\\hsc_arr hsc_ix -> " ++ operation ++ " hsc_arr (" ++ show elemOffset ++ " + (hsc_ix * " ++ show typFieldRatio ++ ")))") + else output ("(\\hsc_arr hsc_ix -> " ++ operation ++ " hsc_arr (" ++ show elemOffset ++ "# +# (hsc_ix *# " ++ show typFieldRatio ++ "#)))") + return False + _ -> testFail pos ("#error " ++ value) outputSpecial _ _ = error "outputSpecial's argument isn't a Special" outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String @@ -406,6 +436,12 @@ binarySearch z nonNegative l u = do u'-l' < u-l) -- @|u' - l'| < |u - l|@ (binarySearch z nonNegative l' u') +isPowerOfTwo :: Integer -> Bool +isPowerOfTwo 0 = False +isPowerOfTwo 1 = True +isPowerOfTwo n = case divMod n 2 of + (m,r) -> if r == 0 then isPowerOfTwo m else False + -- Establishes bounds on the unknown integer. By searching increasingly -- large powers of 2, it'll bracket an integer x by lower & upper -- such that lower <= x <= upper. diff --git a/DirectCodegen.hs b/DirectCodegen.hs index 9bfdd42..85a2cb2 100644 --- a/DirectCodegen.hs +++ b/DirectCodegen.hs @@ -56,9 +56,14 @@ outputDirect config outName outDir outBase name toks = do when (cCrossSafe config) $ forM_ specials (\ (SourcePos file line _,key,_) -> - when (not $ key `elem` ["const","offset","size","alignment","peek","poke","ptr", - "type","enum","error","warning","include","define","undef", - "if","ifdef","ifndef", "elif","else","endif"]) $ + when (not $ key `elem` + ["const","offset","size","alignment","peek","poke","ptr" + ,"type","enum","error","warning","include","define","undef" + ,"if","ifdef","ifndef", "elif","else","endif" + ,"readByteArray","writeByteArray","indexByteArray" + ,"readByteArrayHash","writeByteArrayHash","indexByteArrayHash" + ,"readOffAddrHash","writeOffAddrHash","indexOffAddrHash" + ]) $ die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation")) writeBinaryFile cProgName $ diff --git a/README.rst b/README.rst index 68a6368..2d77e90 100644 --- a/README.rst +++ b/README.rst @@ -195,6 +195,25 @@ Meanings of specific keywords: Computes the alignment, in bytes, of ``struct_type``. It will have type ``Int``. +``#readByteArray ⟨struct_type⟩, ⟨field⟩`` + Outputs a function that indexes into an array of a C struct. It will + have the type ``Prim a => MutableByteArray (PrimState m) -> Int -> m a``. + The context must ensure that ``a`` is a type that can be marshalled + to the C field type. This only supports access to aligned fields and + will fail at compile time if the field is not aligned. The source + expression ``#{readByteArray struct foo, bar} arr 42`` becomes an + expression that has the same behavior as the C expression + ``((struct foo*) arr)[42].bar``. + +``#readByteArrayHash ⟨struct_type⟩, ⟨field⟩`` + Variant of ``#readByteArray`` with unlifted argument and result types. + It will have the type + ``Prim a => MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)``. + The macros ``#readByteArrayHash``, ``#writeByteArayHash``, + ``#indexByteArrayHash``, ``#readOffAddrHash``, ``#writeOffAddrHash``, + and ``#indexOffAddrHash`` are intended to be used to implement instances + of ``Prim`` (see `implementing-instances`_). + ``#enum ⟨type⟩, ⟨constructor⟩, ⟨value⟩, ⟨value⟩, ...`` A shortcut for multiple definitions which use ``#const``. Each ``value`` is a name of a C integer constant, e.g. enumeration value. @@ -247,3 +266,121 @@ The following are unsupported: - ``#{let}`` - ``#{def}`` - Custom constructs + +.. _implementing-instances: + +Implementing Instances +~~~~~~~~~~~~~~~~~~~~~~ + +As an example, the ``Storable`` and ``Prim`` instances for a haskell +data type corresponding to the POSIX ``struct pollfd`` are implemented +below. `IEEE Std 1003.1-2017`_ describes ``struct pollfd`` as: + +.. _`IEEE Std 1003.1-2017`: http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/poll.h.html + ++-------+---------+----------------------------------------+ +| int | fd | The following descriptor being polled. | ++-------+---------+----------------------------------------+ +| short | events | The input event flags. | ++-------+---------+----------------------------------------+ +| short | revents | The output event flags. | ++-------+---------+----------------------------------------+ + +The `Linux poll man page`_ provides a concrete implementation, +describing ``struct pollfd`` as: + +.. _`Linux poll man page`: http://man7.org/linux/man-pages/man2/poll.2.html + +:: + + struct pollfd { + int fd; /* file descriptor */ + short events; /* requested events */ + short revents; /* returned events */ + }; + +This type is most directly expressed in Haskell as: + +:: + + data PollFd = PollFd + { descriptor :: !Fd + , request :: !CShort + , response :: !CShort + } + +We now use ``hsc2hs`` to help write a portable ``Storable`` instance. +The GHC ``NamedFieldPuns`` extension is used for succinctness although +it is not necessary:: + + instance Storable PollFd where + sizeOf _ = #size struct pollfd + alignment _ = #alignment struct pollfd + peek ptr = do + descriptor <- #{peek struct pollfd, fd} ptr + request <- #{peek struct pollfd, events} ptr + response <- #{peek struct pollfd, revents} ptr + return (PollFd{descriptor,request,response}) + poke ptr PollFd{descriptor,request,response} = do + #{poke struct pollfd, fd} ptr descriptor + #{poke struct pollfd, events} ptr request + #{poke struct pollfd, revents} ptr response + +More verbosely, ``hsc2hs`` can also be used to help write portable ``Prim`` +instances that are intended to marshall C data types. (Unlike ``Storable``, +whose sole purpose is to help marshall C data types, ``Prim`` is not used +exclusively for this purpose, but it is occassionally useful in this domain.) +This example uses the GHC extensions ``MagicHash`` and ``UnboxedTuples``, +which are required. It also uses the GHC extension ``NamedFieldPuns``, +which is optional as it was in the ``Storable`` example. Notice that all +the source Haskell hash characters escaped by doubling them:: + + import GHC.Exts + import Data.Primitive.Types (Prim(..),defaultSetByteArray##,defaultSetOffAddr##) + + unInt :: Int -> Int## + unInt (I## i) = i + + instance Prim PollFd where + sizeOf## _ = unInt #{size struct pollfd} + alignment## _ = unInt #{alignment struct pollfd} + indexByteArray## arr i = PollFd + { descriptor = #{indexByteArrayHash struct pollfd, fd} arr i + , request = #{indexByteArrayHash struct pollfd, events} arr i + , response = #{indexByteArrayHash struct pollfd, revents} arr i + } + writeByteArray## arr i PollFd{descriptor,request,response} s0 = + case #{writeByteArrayHash struct pollfd, fd} arr i descriptor s0 of + s1 -> case #{writeByteArrayHash struct pollfd, events} arr i request s1 of + s2 -> #{writeByteArrayHash struct pollfd, revents} arr i response s2 + readByteArray## arr i s0 = case #{readByteArrayHash struct pollfd, fd} arr i s0 of + (## s1, descriptor ##) -> case #{readByteArrayHash struct pollfd, events} arr i s1 of + (## s2, request ##) -> case #{readByteArrayHash struct pollfd, revents} arr i s2 of + (## s3, response ##) -> (## s3, PollFd{descriptor,request,response} ##) + setByteArray## = defaultSetByteArray## + indexOffAddr## arr i = PollFd + { descriptor = #{indexOffAddrHash struct pollfd, fd} arr i + , request = #{indexOffAddrHash struct pollfd, events} arr i + , response = #{indexOffAddrHash struct pollfd, revents} arr i + } + writeOffAddr## arr i PollFd{descriptor,request,response} s0 = + case #{writeOffAddrHash struct pollfd, fd} arr i descriptor s0 of + s1 -> case #{writeOffAddrHash struct pollfd, events} arr i request s1 of + s2 -> #{writeOffAddrHash struct pollfd, revents} arr i response s2 + readOffAddr## arr i s0 = case #{readOffAddrHash struct pollfd, fd} arr i s0 of + (## s1, descriptor ##) -> case #{readOffAddrHash struct pollfd, events} arr i s1 of + (## s2, request ##) -> case #{readOffAddrHash struct pollfd, revents} arr i s2 of + (## s3, response ##) -> (## s3, PollFd{descriptor,request,response} ##) + setOffAddr## = defaultSetOffAddr## + +Keep in mind that, unlike the code-generation for the ``Storable`` instance, +this code-generation will cause a compile-time failure if the operating system +has an esoteric implementation of ``struct pollfd`` with unaligned fields. +Note that the ``Prim`` instances is necessarily more verbose that the +``Storable`` instance. Two factors contribute to this: + +* ``Prim`` deals with both managed and unmanaged memory +* The typeclass methods of ``Prim`` use unlifted types + +Despite the verbosity, this is a portable solution for Haskell code that needs +to pass runtime-managed, unpinned memory to a C library using the unsafe FFI. diff --git a/changelog.md b/changelog.md index 33e8877..5a029c3 100644 --- a/changelog.md +++ b/changelog.md @@ -9,6 +9,9 @@ - Add support for haskell files that use a leading single quote for promoted data constructors. + - Add macros for accessing runtime-managed bytearrays. This uses the naming + scheme from `primitive` and is intended to be used with that library. + ## 0.68.4 - Add support to read command line arguments supplied via response files diff --git a/template-hsc.h b/template-hsc.h index dec0e43..dc83d7f 100644 --- a/template-hsc.h +++ b/template-hsc.h @@ -23,6 +23,10 @@ void *hsc_stdout(void); #define offsetof(t, f) ((size_t) &((t *)0)->f) #endif +#ifndef FIELD_SIZEOF +#define FIELD_SIZEOF(t, f) (sizeof(((t*)0)->f)) +#endif + #if __NHC__ #define hsc_line(line, file) \ hsc_printf ("# %d \"%s\"\n", line, file); @@ -129,3 +133,66 @@ void *hsc_stdout(void); } \ } \ } + +#define hsc_readByteArray(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> readByteArray hsc_arr (%ld + (hsc_ix * %ld)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_writeByteArray(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> writeByteArray hsc_arr (%ld + (hsc_ix * %ld)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_indexByteArray(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> indexByteArray hsc_arr (%ld + (hsc_ix * %ld)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_readByteArrayHash(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> readByteArray# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_writeByteArrayHash(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> writeByteArray# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_indexByteArrayHash(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> indexByteArray# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_readOffAddrHash(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> readOffAddr# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_writeOffAddrHash(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> writeOffAddr# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + } + +#define hsc_indexOffAddrHash(t, f) \ + if ((offsetof(t,f)) % (FIELD_SIZEOF(t,f)) == 0 && (sizeof(t) % (FIELD_SIZEOF(t,f))) == 0) { \ + hsc_printf ("(\\hsc_arr hsc_ix -> indexOffAddr# hsc_arr (%ld# +# (hsc_ix *# %ld#)))", ((offsetof(t,f)) / (FIELD_SIZEOF(t,f))), (sizeof(t) / (FIELD_SIZEOF(t,f)))); \ + } else { \ + hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ + }