<commit_before>{-# LANGUAGE TupleSections #-}

-- | Abstract platform
module ViperVM.Platform.Platform (
   Platform(..), PlatformConfig(..), defaultConfig,
   loadPlatform,
   memoryEndianness, memorySize,
   allocateBuffer, allocateBufferFromRegion, releaseBuffer,
   transferRegion
) where

import Control.Applicative ( (<$>), pure )
import Control.Monad (forM,filterM,void)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)
import Control.Concurrent.STM
import Data.Traversable (Traversable, traverse)
import Data.Foldable (Foldable, foldMap, forM_)
import Data.Monoid (mempty)
import Data.List
import Data.Word (Word64)
import Foreign.Ptr

import qualified ViperVM.Platform.OpenCL as CL
import qualified ViperVM.Platform.CPU as CPU
import ViperVM.Platform.Endianness
import ViperVM.Platform.AllocFree
import ViperVM.Platform.Types
import ViperVM.MMU.Region (regionCover, Region(..))

data PlatformConfig = PlatformConfig {
   libraryOpenCL :: String,
   filterOpenCLDevices :: CL.Device -> IO Bool,
   sysfsPath :: String
}

defaultConfig :: PlatformConfig
defaultConfig = PlatformConfig {
   libraryOpenCL = "libOpenCL.so",
   filterOpenCLDevices = const (return True),
   sysfsPath = "/sys"
}

data Platform = Platform {
   platformMemories :: [Memory],
   platformProcs :: [Proc],
   -- OpenCL specific
   platformOpenCLPlatforms :: [CL.Platform]
}

-- | State used during platform loading
data LoadState = LoadState {
   currentProcID :: ID,
   currentMemID :: ID,
   currentMemories :: [Memory],
   currentProcs :: [Proc]
}

-- | Initial loading state
initLoadState :: LoadState
initLoadState = LoadState {
   currentProcID = 0,
   currentMemID = 0,
   currentMemories = [],
   currentProcs = []
}

-- | Get new Proc ID
newProcId :: Monad m => StateT LoadState m ID
newProcId = do
   curr <- get
   let x = currentProcID curr
   put (curr { currentProcID = x+1 })
   return x

-- | Get new Mem ID
newMemId :: Monad m => StateT LoadState m ID
newMemId = do
   curr <- get
   let x = currentMemID curr
   put (curr { currentMemID = x+1 })
   return x

-- | Register a new memory
registerMemory :: [Proc] -> MemoryPeer -> StateT LoadState IO Memory
registerMemory procs peer = do
   memId <- newMemId
   mem <- lift $ wrapMemoryPeer memId procs peer
   curr <- get
   put (curr { currentMemories = mem : currentMemories curr})
   return mem

-- | Register a new proc
registerProc :: ProcPeer -> StateT LoadState IO Proc
registerProc peer = do
   procId <- newProcId
   proc <- lift $ wrapProcPeer procId peer
   curr <- get
   put (curr { currentProcs = proc : currentProcs curr})
   return proc



-- | Load OpenCL platform
loadOpenCLPlatform :: PlatformConfig -> StateT LoadState IO [CL.Platform]
loadOpenCLPlatform config = do
   clLib <- lift $ CL.loadOpenCL (libraryOpenCL config)
   clPlatforms <- lift $ CL.getPlatforms clLib
   clDevices <- lift $ concat <$> forM clPlatforms (\pf -> map (pf,) <$> CL.getPlatformDevices pf)
   clDevices' <- lift $ filterM (filterOpenCLDevices config . snd) clDevices
   clContexts <- lift $ forM clDevices' (\(pf,dev) -> CL.createContext pf [dev])
   forM_ (clContexts `zip` clDevices') $ \(ctx,(_,dev)) -> case ctx of
      Left err -> error ("Invalid context: " ++ show err)
      Right ctx' -> do
         endianness <- lift $ getOpenCLDeviceEndianness dev
         size <- lift $ CL.getDeviceGlobalMemSize' dev
         let memPeer = OpenCLMemory {
                  clMemLibrary = clLib,
                  clMemDevice = dev,
                  clMemContext = ctx',
                  clMemEndianness = endianness,
                  clMemSize = size
               }
             prcPeer = OpenCLProc {
                  clProcDevice = dev,
                  clProcContext = ctx'
               }
         proc <- registerProc prcPeer
         void (registerMemory [proc] memPeer)

   return clPlatforms


-- | Load host platform
loadHostPlatform :: PlatformConfig -> StateT LoadState IO ()
loadHostPlatform config = do
   numa <- lift $ CPU.loadNUMA (sysfsPath config)
   hostEndianness <- lift $ getMemoryEndianness
   forM_ (CPU.numaNodes numa) $ \node -> do
      let m = CPU.nodeMemory node
      (total,_) <- lift $ CPU.nodeMemoryStatus m
      let memPeer = HostMemory {
            hostMemEndianness = hostEndianness,
            hostMemSize = total
          }
          procs = []
      void (registerMemory procs memPeer)

<commit_msg>[OpenCL] Simplify OpenCL platform loading code<commit_after>-- | Abstract platform
module ViperVM.Platform.Platform (
   Platform(..), PlatformConfig(..), defaultConfig,
   loadPlatform,
   memoryEndianness, memorySize,
   allocateBuffer, allocateBufferFromRegion, releaseBuffer,
   transferRegion
) where

import Control.Applicative ( (<$>), pure )
import Control.Monad (filterM,void)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)
import Control.Concurrent.STM
import Data.Traversable (Traversable, traverse)
import Data.Foldable (Foldable, foldMap, forM_)
import Data.Monoid (mempty)
import Data.List
import Data.Word (Word64)
import Foreign.Ptr

import qualified ViperVM.Platform.OpenCL as CL
import qualified ViperVM.Platform.CPU as CPU
import ViperVM.Platform.Endianness
import ViperVM.Platform.AllocFree
import ViperVM.Platform.Types
import ViperVM.MMU.Region (regionCover, Region(..))

data PlatformConfig = PlatformConfig {
   libraryOpenCL :: String,
   filterOpenCLDevices :: CL.Device -> IO Bool,
   sysfsPath :: String
}

defaultConfig :: PlatformConfig
defaultConfig = PlatformConfig {
   libraryOpenCL = "libOpenCL.so",
   filterOpenCLDevices = const (return True),
   sysfsPath = "/sys"
}

data Platform = Platform {
   platformMemories :: [Memory],
   platformProcs :: [Proc],
   -- OpenCL specific
   platformOpenCLPlatforms :: [CL.Platform]
}

-- | State used during platform loading
data LoadState = LoadState {
   currentProcID :: ID,
   currentMemID :: ID,
   currentMemories :: [Memory],
   currentProcs :: [Proc]
}

-- | Initial loading state
initLoadState :: LoadState
initLoadState = LoadState {
   currentProcID = 0,
   currentMemID = 0,
   currentMemories = [],
   currentProcs = []
}

-- | Get new Proc ID
newProcId :: Monad m => StateT LoadState m ID
newProcId = do
   curr <- get
   let x = currentProcID curr
   put (curr { currentProcID = x+1 })
   return x

-- | Get new Mem ID
newMemId :: Monad m => StateT LoadState m ID
newMemId = do
   curr <- get
   let x = currentMemID curr
   put (curr { currentMemID = x+1 })
   return x

-- | Register a new memory
registerMemory :: [Proc] -> MemoryPeer -> StateT LoadState IO Memory
registerMemory procs peer = do
   memId <- newMemId
   mem <- lift $ wrapMemoryPeer memId procs peer
   curr <- get
   put (curr { currentMemories = mem : currentMemories curr})
   return mem

-- | Register a new proc
registerProc :: ProcPeer -> StateT LoadState IO Proc
registerProc peer = do
   procId <- newProcId
   proc <- lift $ wrapProcPeer procId peer
   curr <- get
   put (curr { currentProcs = proc : currentProcs curr})
   return proc



-- | Load OpenCL platform
loadOpenCLPlatform :: PlatformConfig -> StateT LoadState IO [CL.Platform]
loadOpenCLPlatform config = do
   lib <- lift $ CL.loadOpenCL (libraryOpenCL config)
   platforms <- lift $ CL.getPlatforms lib

   forM_ platforms $ \pf -> do
      devices <- lift $ filterM (filterOpenCLDevices config) =<< CL.getPlatformDevices pf
      forM_ devices $ \dev -> do
         context <- lift $ CL.createContext pf [dev]

         case context of
            Left err -> error ("Invalid context: " ++ show err)
            Right ctx' -> do
               endianness <- lift $ getOpenCLDeviceEndianness dev
               size <- lift $ CL.getDeviceGlobalMemSize' dev
               let memPeer = OpenCLMemory {
                        clMemLibrary = lib,
                        clMemDevice = dev,
                        clMemContext = ctx',
                        clMemEndianness = endianness,
                        clMemSize = size
                     }
                   prcPeer = OpenCLProc {
                        clProcDevice = dev,
                        clProcContext = ctx'
                     }
               proc <- registerProc prcPeer
               void (registerMemory [proc] memPeer)

   return platforms


-- | Load host platform
loadHostPlatform :: PlatformConfig -> StateT LoadState IO ()
loadHostPlatform config = do
   numa <- lift $ CPU.loadNUMA (sysfsPath config)
   hostEndianness <- lift $ getMemoryEndianness
   forM_ (CPU.numaNodes numa) $ \node -> do
      let m = CPU.nodeMemory node
      (total,_) <- lift $ CPU.nodeMemoryStatus m
      let memPeer = HostMemory {
            hostMemEndianness = hostEndianness,
            hostMemSize = total
          }
          procs = []
      void (registerMemory procs memPeer)


{'fraction_non_alphanumeric': 0.09438832772166106, 'fraction_numerical': 0.0013468013468013469, 'mean_word_length': 2.7662721893491122, 'pattern_counts': {'":': 0, '<': 46, '<?xml version=': 0, '>': 34, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6252824', 'n_tokens_mistral': 2675, 'n_tokens_neox': 2592, 'n_words': 781}