Draft ghc 9.2.* support and nix support

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -17,3 +17,6 @@ local/
 /stack.yaml.lock
 .ipynb_checkpoints
 /accelerate-llvm-native/accelerate-llvm-native.buildinfo
+.direnv
+.pre-commit-config.yaml
+result

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/Execute.hs

@@ -2,11 +2,9 @@
 {-# LANGUAGE FlexibleContexts         #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE GADTs                    #-}
-{-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE RecordWildCards          #-}
 {-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE TemplateHaskell          #-}
 {-# LANGUAGE TypeApplications         #-}
 {-# LANGUAGE TypeOperators            #-}
 {-# LANGUAGE ViewPatterns             #-}
@@ -55,6 +53,7 @@ import Control.Concurrent                                           ( myThreadId
 import Control.Concurrent.Extra                                     ( getThreadId )
 import Control.Monad.State                                          ( gets )
 import Control.Monad.Trans                                          ( liftIO )
+import Control.Monad (void)
 import Data.ByteString.Short                                        ( ShortByteString )
 import Data.IORef                                                   ( newIORef, readIORef, writeIORef )
 import Data.List                                                    ( find )
@@ -64,7 +63,7 @@ import Data.Foldable                                                ( asum )
 import Formatting
 import System.CPUTime                                               ( getCPUTime )
 import qualified Data.ByteString.Short                              as S
-import qualified Data.ByteString.Short.Extra                        as S
+import qualified Data.ByteString.Short.Extra                        as SE
 import qualified Data.ByteString.Short.Char8                        as S8
 import qualified Data.Sequence                                      as Seq
 import qualified Data.DList                                         as DL
@@ -326,7 +325,7 @@ foldAllOp tp NativeR{..} gamma aenv arr = do
                               touchLifetime nativeExecutable
 
       job1  <- mkJobUsingIndex ranges (nativeExecutable !# "foldAllP1") gamma aenv dim1 param1 (tmp, manifest arr)
-                 `andThen` do schedule workers job2
+                 `andThen` schedule workers job2
 
       liftIO $ schedule workers job1
   --
@@ -498,17 +497,16 @@ scan'Op
     -> Val aenv
     -> Delayed (Array (sh, Int) e)
     -> Par Native (Future (Array (sh, Int) e, Array sh e))
-scan'Op repr exe gamma aenv arr@(delayedShape -> (sz, n)) = do
-  case n of
-    0 -> do
-      out     <- allocateRemote repr (sz, 0)
-      sum     <- generateOp (reduceRank repr) exe gamma aenv sz
-      future  <- new
-      fork $ do sum' <- get sum
-                put future (out, sum')
-      return future
-    --
-    _ -> scan'Core repr exe gamma aenv arr
+scan'Op repr exe gamma aenv arr@(delayedShape -> (sz, n)) = case n of
+  0 -> do
+    out     <- allocateRemote repr (sz, 0)
+    sum     <- generateOp (reduceRank repr) exe gamma aenv sz
+    future  <- new
+    fork $ do sum' <- get sum
+              put future (out, sum')
+    return future
+  --
+  _ -> scan'Core repr exe gamma aenv arr
 
 {-# INLINE scan'Core #-}
 scan'Core
@@ -719,7 +717,7 @@ stencilCore repr NativeR{..} gamma aenv halo sh paramsR params = do
       outs    = asum . flip fmap (stencilBorders shr sh halo) $ \(u,v) -> divideWork shr splits minsize u v (,,)
 
       sub :: sh -> sh -> sh
-      sub a b = go shr a b
+      sub = go shr
         where
           go :: ShapeR t -> t -> t -> t
           go ShapeRz          ()      ()      = ()
@@ -787,8 +785,7 @@ aforeignOp name _ _ asm arr = do
   $ lookupFunction name exe
 
 lookupFunction :: ShortByteString -> Lifetime FunctionTable -> Maybe Function
-lookupFunction name nativeExecutable = do
-  find (\(n,_) -> S.take (S.length n - 65) n == name) (functionTable (unsafeGetValue nativeExecutable))
+lookupFunction name nativeExecutable = find (\(n,_) -> SE.take (S.length n - 65) n == name) (functionTable (unsafeGetValue nativeExecutable))
 
 andThen :: (Maybe a -> t) -> a -> t
 andThen f g = f (Just g)
@@ -875,8 +872,7 @@ mkJob :: Int
       -> params
       -> Maybe Action
       -> Par Native Job
-mkJob splits minsize fun gamma aenv shr from to paramsR params jobDone =
-  mkJobUsing (divideWork shr splits minsize from to (,,)) fun gamma aenv shr paramsR params jobDone
+mkJob splits minsize fun gamma aenv shr from to = mkJobUsing (divideWork shr splits minsize from to (,,)) fun gamma aenv shr
 
 {-# INLINABLE mkJobUsing #-}
 mkJobUsing
@@ -950,7 +946,7 @@ mkTasksUsingIndex ranges (name, f) gamma aenv shr paramsR params = do
 -- --------------------
 
 memset :: Ptr Word8 -> Word8 -> Int -> IO ()
-memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return ()
+memset p w s = void (c_memset p (fromIntegral w) (fromIntegral s))
 
 foreign import ccall unsafe "string.h memset" c_memset
     :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
@@ -970,39 +966,37 @@ foreign import ccall unsafe "string.h memset" c_memset
 --
 timed :: ShortByteString -> Job -> IO Job
 timed name job =
-  case Debug.debuggingIsEnabled of
-    False -> return job
-    True  -> do
-      yes     <- Debug.getFlag Debug.dump_exec
-      verbose <- Debug.getFlag Debug.verbose
-      if yes
-        then do
-          ref1 <- newIORef 0
-          ref2 <- newIORef 0
-          let start = do !wall0 <- getMonotonicTime
-                         !cpu0  <- getCPUTime
-                         writeIORef ref1 wall0
-                         writeIORef ref2 cpu0
-
-              end   = do !cpu1  <- getCPUTime
-                         !wall1 <- getMonotonicTime
-                         !wall0 <- readIORef ref1
-                         !cpu0  <- readIORef ref2
-                         --
-                         let wallTime = wall1 - wall0
-                             cpuTime  = fromIntegral (cpu1 - cpu0) * 1E-12
-                             name' | verbose   = name
-                                   | otherwise = S.take (S.length name - 65) name
-                         --
-                         Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsedP) (S8.unpack name') wallTime cpuTime
-              --
-          return $ Job { jobTasks = start Seq.<| jobTasks job
-                       , jobDone  = case jobDone job of
-                                      Nothing       -> Just end
-                                      Just finished -> Just (finished >> end)
-                       }
-        else
-          return job
+  if Debug.debuggingIsEnabled then (do
+  yes     <- Debug.getFlag Debug.dump_exec
+  verbose <- Debug.getFlag Debug.verbose
+  if yes
+    then do
+      ref1 <- newIORef 0
+      ref2 <- newIORef 0
+      let start = do !wall0 <- getMonotonicTime
+                     !cpu0  <- getCPUTime
+                     writeIORef ref1 wall0
+                     writeIORef ref2 cpu0
+
+          end   = do !cpu1  <- getCPUTime
+                     !wall1 <- getMonotonicTime
+                     !wall0 <- readIORef ref1
+                     !cpu0  <- readIORef ref2
+                     --
+                     let wallTime = wall1 - wall0
+                         cpuTime  = fromIntegral (cpu1 - cpu0) * 1E-12
+                         name' | verbose   = name
+                               | otherwise = SE.take (S.length name - 65) name
+                     --
+                     Debug.traceM Debug.dump_exec ("exec: " % string % " " % Debug.elapsedP) (S8.unpack name') wallTime cpuTime
+          --
+      return $ Job { jobTasks = start Seq.<| jobTasks job
+                   , jobDone  = case jobDone job of
+                                  Nothing       -> Just end
+                                  Just finished -> Just (finished >> end)
+                   }
+    else
+      return job) else return job
 
 -- accelerate/cbits/clock.c
 foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE CPP          #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- |
 -- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Marshal
@@ -31,9 +32,21 @@ import Data.Array.Accelerate.LLVM.Native.Target
 import qualified Data.DList                                     as DL
 import qualified Foreign.LibFFI                                 as FFI
 
+#include "MachDeps.h"
+
 instance Marshal Native where
   type ArgR Native = FFI.Arg
 
-  marshalInt = FFI.argInt
+  marshalInt = 
+#if SIZEOF_HSINT==64
+    FFI.argInt64
+#elif SIZEOF_HSINT==32
+    FFI.argInt32
+#elif SIZEOF_HSINT==16
+    FFI.argInt16
+#else 
+    error "unsupported Int size"
+#endif 
+
   marshalScalarData' _ = return . DL.singleton . FFI.argPtr . unsafeUniqueArrayPtr
 

accelerate-llvm-native/src/Data/Array/Accelerate/LLVM/Native/Plugin.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP             #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports   #-}
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 -- |
@@ -27,7 +28,12 @@ import Data.IORef
 import Data.List
 import qualified Data.Map                                           as Map
 
-#if __GLASGOW_HASKELL__ >= 900
+#if __GLASGOW_HASKELL__ >= 902
+import GHC.Plugins
+import GHC (Backend (NoBackend, Interpreter), backend)
+import GHC.Linker.Loader (loadCmdLineLibs)
+import Data.Maybe (fromMaybe)
+#elif __GLASGOW_HASKELL__ >= 900
 import GHC.Plugins
 import GHC.Runtime.Linker
 #else
@@ -66,31 +72,44 @@ pass :: HasCallStack => ModGuts -> CoreM ModGuts
 pass guts = do
   -- Determine the current build environment
   --
-  hscEnv   <- getHscEnv
+  hscEnv :: HscEnv   <- getHscEnv
   dynFlags <- getDynFlags
   this     <- getModule
 
+
+
   -- Gather annotations for the extra object files which must be supplied to the
   -- linker in order to complete the current module.
   --
   paths   <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts)
 
-  when (not (null paths))
+  unless (null paths)
     $ debugTraceMsg
     $ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths))
 
   -- The linking method depends on the current build target
   --
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,1,0)
+  case backend dynFlags of 
+    NoBackend -> return ()
+    Interpreter -> 
+#else
   case hscTarget dynFlags of
     HscNothing     -> return ()
     HscInterpreted ->
+#endif
       -- We are in interactive mode (ghci)
       --
-      when (not (null paths)) . liftIO $ do
+      unless (null paths) . liftIO $ do
         let opts  = ldInputs dynFlags
             objs  = map optionOfPath paths
         --
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,1,0)
+        let interp = fromMaybe (error "HscEnv doesn't carry an Interp") $ hsc_interp hscEnv
+        loadCmdLineLibs interp
+#else
         linkCmdLineLibs
+#endif
                $ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}
 
     -- This case is not necessary for GHC-8.6 and above.
@@ -122,7 +141,7 @@ pass guts = do
 
       -- Make sure the linker flags are up-to-date.
       --
-      when (not (isNoLink (ghcLink dynFlags))) $ do
+      unless (isNoLink (ghcLink dynFlags)) $ do
         linker_info <- getLinkerInfo dynFlags
         writeIORef (rtldInfo dynFlags)
           $ Just
@@ -134,8 +153,9 @@ pass guts = do
               AixLD     opts -> AixLD     (nub (opts ++ allObjs))
               LlvmLLD   opts -> LlvmLLD   (nub (opts ++ allObjs))
               UnknownLD      -> UnknownLD  -- no linking performed?
-#endif
+#else
       return ()
+#endif
 
   return guts
 

accelerate-llvm/src/Data/ByteString/Short/Char8.hs

@@ -22,7 +22,7 @@ import Data.ByteString.Short                                        ( ShortByteS
 import Prelude                                                      as P hiding ( takeWhile )
 import qualified Data.ByteString.Internal                           as BI
 import qualified Data.ByteString.Short                              as BS
-import qualified Data.ByteString.Short.Extra                        as BS
+import qualified Data.ByteString.Short.Extra                        as BSE 
 
 
 -- | /O(n)/ Convert a 'ShortByteString' into a list.
@@ -42,5 +42,5 @@ pack = BS.pack . P.map BI.c2w
 --
 {-# INLINEABLE takeWhile #-}
 takeWhile :: (Char -> Bool) -> ShortByteString -> ShortByteString
-takeWhile f = BS.takeWhile (f . BI.w2c)
+takeWhile f = BSE.takeWhile (f . BI.w2c)
 

cabal.project

@@ -2,25 +2,25 @@ packages: accelerate-llvm
           accelerate-llvm-native
           accelerate-llvm-ptx
 
-source-repository-package
-    type: git
-    location: https://github.com/tmcdonell/accelerate.git
-    tag: a9cf26f40cea53042659cca7d509ae2acafd3857
-    -- Cabal builds from an sdist, and `accelerate.cabal` references files that
-    -- don't exist on a fresh clone. Cabal 3.8.0.0 will do this automatically.
-    --
-    -- XXX: For some reason cabal just stops when the command returns 0? So
-    --      negating this seems to 'work'
-    post-checkout-command: bash -c "! git submodule update --init --recursive"
+-- source-repository-package
+--     type: git
+--     location: https://github.com/tmcdonell/accelerate.git
+--     tag: a9cf26f40cea53042659cca7d509ae2acafd3857
+--     -- Cabal builds from an sdist, and `accelerate.cabal` references files that
+--     -- don't exist on a fresh clone. Cabal 3.8.0.0 will do this automatically.
+--     --
+--     -- XXX: For some reason cabal just stops when the command returns 0? So
+--     --      negating this seems to 'work'
+--     post-checkout-command: bash -c "! git submodule update --init --recursive"
 
 -- This is for LLVM 12, comment this stanza out to fall back to the latest
 -- versions of these packages published to Hackage
-source-repository-package
-    type: git
-    location: https://github.com/llvm-hs/llvm-hs.git
-    tag: eda85a2bbe362a0b89df5adce0cb65e4e755eac5
-    subdir: llvm-hs llvm-hs-pure
-
+-- source-repository-package
+--     type: git
+--     location: https://github.com/llvm-hs/llvm-hs.git
+--     tag: eda85a2bbe362a0b89df5adce0cb65e4e755eac5
+--     subdir: llvm-hs llvm-hs-pure
+-- 
 -- package accelerate
 --     flags: +debug