Initial (WIP)HEADmaster

7 files changed, 359 insertions, 0 deletions

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