From a5a5e7f275de6ec9784f75a3e2d313e4eee807fa Mon Sep 17 00:00:00 2001 From: Paul Oliver Date: Thu, 29 Feb 2024 02:55:06 +0100 Subject: Initial (WIP) --- .gitignore | 1 + app/Arch/Dummy.hs | 56 +++++++++++++++ app/Config.hs | 19 +++++ app/Core.hs | 204 ++++++++++++++++++++++++++++++++++++++++++++++++++++ app/Main.hs | 6 ++ app/UI/Benchmark.hs | 41 +++++++++++ fsalis.cabal | 32 +++++++++ 7 files changed, 359 insertions(+) create mode 100644 .gitignore create mode 100644 app/Arch/Dummy.hs create mode 100644 app/Config.hs create mode 100644 app/Core.hs create mode 100644 app/Main.hs create mode 100644 app/UI/Benchmark.hs create mode 100644 fsalis.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/app/Arch/Dummy.hs b/app/Arch/Dummy.hs new file mode 100644 index 0000000..4d26369 --- /dev/null +++ b/app/Arch/Dummy.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Arch.Dummy + ( Process(..) + , procAncestor + , procMemBlocks + , procRep + , procSliceM + , procStepM + , bimapMnemonic + , bimapSymbol + ) where + +import Control.Monad.ST (ST) +import Data.Bimap (Bimap, fromList) +import Data.Vector.Unboxed.Deriving (derivingUnbox) +import qualified Data.Vector.Unboxed.Mutable as M (STVector) +import Data.Word (Word64, Word8) +import Text.Printf (printf) + +data Process = + Process + deriving (Show) + +$(derivingUnbox "Process" [t|Process -> Word64|] [|const 1|] [|const Process|]) + +procAncestor :: Process +procAncestor = Process + +procMemBlocks :: Process -> [(Word64, Word64)] +procMemBlocks _ = [] + +procRep :: Process -> [(String, String)] +procRep _ = [("dmmy", "----")] + +procSliceM :: M.STVector s Process -> M.STVector s Word8 -> Word64 -> ST s Word64 +procSliceM _ _ _ = return 1 + +procStepM :: M.STVector s Process -> M.STVector s Word8 -> Word64 -> ST s (Maybe Process) +procStepM _ _ _ = return Nothing + +bimapMnemonic :: Bimap Word8 [String] +bimapMnemonic = fromList [(i, ["dmmy", printf "0x%x" i]) | i <- [0 .. 0xff]] + +bimapSymbol :: Bimap Word8 Char +bimapSymbol = + fromList + $ zip [0 .. 0xff] + $ concat + [ "⠀⠁⠂⠃⠄⠅⠆⠇⡀⡁⡂⡃⡄⡅⡆⡇⠈⠉⠊⠋⠌⠍⠎⠏⡈⡉⡊⡋⡌⡍⡎⡏⠐⠑⠒⠓⠔⠕⠖⠗⡐⡑⡒⡓⡔⡕⡖⡗⠘⠙⠚⠛⠜⠝⠞⠟⡘⡙⡚⡛⡜⡝⡞⡟" + , "⠠⠡⠢⠣⠤⠥⠦⠧⡠⡡⡢⡣⡤⡥⡦⡧⠨⠩⠪⠫⠬⠭⠮⠯⡨⡩⡪⡫⡬⡭⡮⡯⠰⠱⠲⠳⠴⠵⠶⠷⡰⡱⡲⡳⡴⡵⡶⡷⠸⠹⠺⠻⠼⠽⠾⠿⡸⡹⡺⡻⡼⡽⡾⡿" + , "⢀⢁⢂⢃⢄⢅⢆⢇⣀⣁⣂⣃⣄⣅⣆⣇⢈⢉⢊⢋⢌⢍⢎⢏⣈⣉⣊⣋⣌⣍⣎⣏⢐⢑⢒⢓⢔⢕⢖⢗⣐⣑⣒⣓⣔⣕⣖⣗⢘⢙⢚⢛⢜⢝⢞⢟⣘⣙⣚⣛⣜⣝⣞⣟" + , "⢠⢡⢢⢣⢤⢥⢦⢧⣠⣡⣢⣣⣤⣥⣦⣧⢨⢩⢪⢫⢬⢭⢮⢯⣨⣩⣪⣫⣬⣭⣮⣯⢰⢱⢲⢳⢴⢵⢶⢷⣰⣱⣲⣳⣴⣵⣶⣷⢸⢹⢺⢻⢼⢽⢾⢿⣸⣹⣺⣻⣼⣽⣾⣿" + ] diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 index 0000000..f704804 --- /dev/null +++ b/app/Config.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Strict #-} + +module Config + ( coreCount + , coreSize + , syncInterval + ) where + +import Data.Bits ((!<<.)) +import Data.Word (Word64) + +coreCount :: Int +coreCount = 2 + +coreSize :: Word64 +coreSize = 1 !<<. 20 + +syncInterval :: Int +syncInterval = 1 !<<. 20 diff --git a/app/Core.hs b/app/Core.hs new file mode 100644 index 0000000..af61b68 --- /dev/null +++ b/app/Core.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module Core + ( CoreState(..) + , SalisState(..) + , new + , step + ) where + +import Control.Monad (replicateM, replicateM_, when) +import Control.Monad.Par (NFData, parMap, runPar) +import Control.Monad.ST (ST, runST) +import Control.Monad.State.Strict (State, evalState, state) +import Data.Bits ((!<<.), (!>>.), (.^.), (.|.), complementBit) +import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef, writeSTRef) +import qualified Data.Vector as V (Vector, fromList) +import qualified Data.Vector.Unboxed as U (Vector, fromList, replicate, thaw, unsafeFreeze) +import qualified Data.Vector.Unboxed.Mutable as M (STVector, unsafeModify, unsafeRead) +import Data.Word (Word64, Word8) +import GHC.Generics (Generic) +import System.Random.SplitMix (SMGen, mkSMGen, nextWord64) + +import Arch.Dummy (Process(..), procAncestor, procSliceM, procStepM) +import Config (coreCount, coreSize, syncInterval) + +mvecInit :: U.Vector Word8 +mvecInit = U.replicate (fromIntegral coreSize) 0 + +mvecLoop :: Word64 -> Word64 +mvecLoop = (`mod` coreSize) + +mvecMutateM :: M.STVector s Word8 -> Word64 -> Word64 -> ST s () +mvecMutateM mvecM a b = do + let a' = fromIntegral $ mvecLoop a + let b' = fromIntegral b + when (b /= 0) $ M.unsafeModify mvecM (`complementBit` b') a' + +mutaSeeds :: State SMGen [[Word64]] +mutaSeeds = replicateM coreCount $ replicateM 4 $ state nextWord64 + +mutaInit :: Word64 -> [[Word64]] +mutaInit 0 = replicate coreCount $ replicate 4 0 +mutaInit s = evalState mutaSeeds $ mkSMGen s + +mutaR64 :: Word64 -> Int -> Word64 +mutaR64 x k = (x !<<. k) .|. (x !>>. (64 - k)) + +mutaXorM :: M.STVector s Word64 -> Int -> Int -> ST s () +mutaXorM mutaM a b = M.unsafeRead mutaM b >>= \b' -> M.unsafeModify mutaM (.^. b') a + +mutaNextM :: M.STVector s Word64 -> ST s Word64 +mutaNextM mutaM = do + s1 <- M.unsafeRead mutaM 1 + let r = mutaR64 (s1 * 5) 7 * 9 + let t = s1 !<<. 17 + mutaXorM mutaM 2 0 + mutaXorM mutaM 3 1 + mutaXorM mutaM 1 2 + mutaXorM mutaM 0 3 + M.unsafeModify mutaM (.^. t) 2 + M.unsafeModify mutaM (`mutaR64` 45) 3 + return r + +mutaCosmicRayM :: M.STVector s Word64 -> M.STVector s Word8 -> ST s () +mutaCosmicRayM mutaM mvecM = do + a <- mutaNextM mutaM + b <- mutaNextM mutaM + mvecMutateM mvecM a (b `mod` 8) + +pvecInit :: U.Vector Process +pvecInit = U.fromList [procAncestor] + +pvecBirthM :: M.STVector s Process -> Maybe Process -> ST s () +pvecBirthM _ _ = return () + +data CoreState = CoreState + { loop :: Word64 + , mall :: Word64 + , pnum :: Word64 + , pcap :: Word64 + , pfst :: Word64 + , plst :: Word64 + , pcur :: Word64 + , psli :: Word64 + , muta :: U.Vector Word64 + , mvec :: U.Vector Word8 + , pvec :: U.Vector Process + } deriving (Generic, NFData) + +data CoreStateM s = CoreStateM + { loopM :: STRef s Word64 + , mallM :: STRef s Word64 + , pnumM :: STRef s Word64 + , pcapM :: STRef s Word64 + , pfstM :: STRef s Word64 + , plstM :: STRef s Word64 + , pcurM :: STRef s Word64 + , psliM :: STRef s Word64 + , mutaM :: M.STVector s Word64 + , mvecM :: M.STVector s Word8 + , pvecM :: M.STVector s Process + } + +coreInit :: [Word64] -> CoreState +coreInit s = + CoreState + { loop = 0 + , mall = 0 + , pnum = 1 + , pcap = 1 + , pfst = 0 + , plst = 0 + , pcur = 0 + , psli = 0 + , muta = U.fromList s + , mvec = mvecInit + , pvec = pvecInit + } + +coreCycle :: Int -> CoreState -> CoreState +coreCycle n c = runST $ coreThawM c >>= (\c' -> replicateM_ n (coreStepM c') >> coreFreezeM c') + +coreThawM :: CoreState -> ST s (CoreStateM s) +coreThawM CoreState {..} = + CoreStateM + <$> newSTRef loop + <*> newSTRef mall + <*> newSTRef pnum + <*> newSTRef pcap + <*> newSTRef pfst + <*> newSTRef plst + <*> newSTRef pcur + <*> newSTRef psli + <*> U.thaw muta + <*> U.thaw mvec + <*> U.thaw pvec + +coreStepM :: CoreStateM s -> ST s () +coreStepM c@CoreStateM {..} = do + psli' <- readSTRef psliM + pcur' <- readSTRef pcurM + if psli' /= 0 + then do + modifySTRef' psliM $ subtract 1 + child <- procStepM pvecM mvecM pcur' + pvecBirthM pvecM child + else do + plst' <- readSTRef plstM + if pcur' /= plst' + then do + modifySTRef' pcurM succ + pnext <- readSTRef pcurM + pnsli <- procSliceM pvecM mvecM pnext + writeSTRef psliM pnsli + coreStepM c + else do + pnext <- readSTRef pfstM + pnsli <- procSliceM pvecM mvecM pnext + modifySTRef' loopM succ + writeSTRef pcurM pnext + writeSTRef psliM pnsli + mutaCosmicRayM mutaM mvecM + coreStepM c + +coreFreezeM :: CoreStateM s -> ST s CoreState +coreFreezeM CoreStateM {..} = + CoreState + <$> readSTRef loopM + <*> readSTRef mallM + <*> readSTRef pnumM + <*> readSTRef pcapM + <*> readSTRef pfstM + <*> readSTRef plstM + <*> readSTRef pcurM + <*> readSTRef psliM + <*> U.unsafeFreeze mutaM + <*> U.unsafeFreeze mvecM + <*> U.unsafeFreeze pvecM + +data SalisState = SalisState + { iters :: Int + , syncs :: Int + , cores :: V.Vector CoreState + } + +new :: Word64 -> SalisState +new s = SalisState 0 0 $ V.fromList $ map coreInit $ mutaInit s + +step :: Int -> SalisState -> SalisState +step n s@SalisState {iters} = stepAndSync (syncInterval - iters `mod` syncInterval) n s + +stepAndSync :: Int -> Int -> SalisState -> SalisState +stepAndSync d n = + if n >= d + then stepAndSync syncInterval (n - d) . sync . stepCores d + else stepCores n + +stepCores :: Int -> SalisState -> SalisState +stepCores n s@SalisState {iters, cores} = s {iters = n + iters, cores = runPar $ parMap (coreCycle n) cores} + +sync :: SalisState -> SalisState +sync s@SalisState {syncs} = s {syncs = succ syncs} diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..4744e25 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import UI.Benchmark (selectedMain) + +main :: IO () +main = selectedMain diff --git a/app/UI/Benchmark.hs b/app/UI/Benchmark.hs new file mode 100644 index 0000000..dd2960a --- /dev/null +++ b/app/UI/Benchmark.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE RecordWildCards #-} + +module UI.Benchmark + ( selectedMain + ) where + +import Prelude hiding (take) + +import Control.Monad (forM_) +import Data.Vector.Unboxed (take) +import Data.Word (Word64) +import System.Environment (getArgs) +import Text.Printf (printf) + +import Core (CoreState(..), SalisState(..), new, step) + +selectedMain :: IO () +selectedMain = do + args <- getArgs + let x = (read $ head args :: Word64) + let n = (read $ args !! 1 :: Int) + let SalisState {..} = step n $ new x + printf "Salis speed test\n" + printf "Using seed : 0x%x\n" x + printf "Will run N cycles : %i\n" n + printf "\n" + printf "iters : %i\n" iters + printf "syncs : %i\n" syncs + forM_ cores $ \CoreState {..} -> do + printf "\n" + printf "loop : %s\n" $ show loop + printf "mall : %s\n" $ show mall + printf "pnum : %s\n" $ show pnum + printf "pcap : %s\n" $ show pcap + printf "pfst : %s\n" $ show pfst + printf "plst : %s\n" $ show plst + printf "pcur : %s\n" $ show pcur + printf "psli : %s\n" $ show psli + printf "muta : %s\n" $ show muta + printf "mvec : %s\n" $ show $ take 16 mvec + printf "pvec : %s\n" $ show $ take 16 pvec diff --git a/fsalis.cabal b/fsalis.cabal new file mode 100644 index 0000000..792605e --- /dev/null +++ b/fsalis.cabal @@ -0,0 +1,32 @@ +cabal-version: 3.4 + +name: fsalis +version: 0.1.0.0 +author: Paul Oliver +maintainer: contact@pauloliver.dev +build-type: Simple + +executable fsalis + main-is: Main.hs + hs-source-dirs: app + other-modules: + Arch.Dummy + Config + Core + UI.Benchmark + ghc-options: + -O2 + -Wall + -fllvm + -funbox-strict-fields + -rtsopts + -threaded + build-depends: + base + , bimap + , monad-par + , mtl + , splitmix + , vector + , vector-th-unbox + default-language: GHC2021 -- cgit v1.2.1