Adding bytearray read/write/index constructs

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.

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 $

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.

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

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"); \
+  }