From 6ccc7ccf2acef5a7215b9c0ecaa31ec48d573018 Mon Sep 17 00:00:00 2001 From: Johl Brown Date: Wed, 25 Mar 2026 14:16:09 +1000 Subject: [PATCH] Add benchmark harness and compiled evaluator --- .gitignore | 2 + README.md | 28 ++- build.sh | 8 +- src/Bench.hs | 459 ++++++++++++++++++++++++++++++++++++++++++++++ src/Compiled.hs | 267 +++++++++++++++++++++++++++ src/bench_main.hs | 13 ++ 6 files changed, 775 insertions(+), 2 deletions(-) create mode 100644 src/Bench.hs create mode 100644 src/Compiled.hs create mode 100644 src/bench_main.hs diff --git a/.gitignore b/.gitignore index 0fd991b..1642584 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,8 @@ *.o *.jsmod fractran +fractran-bench +*.prof .vscode/ web/node_modules web/gen diff --git a/README.md b/README.md index b983f08..71b9d0f 100644 --- a/README.md +++ b/README.md @@ -11,7 +11,33 @@ Here's the implementation with some demo (hard coded) FRACTRAN programs called i ## Building and running the code -You need an installation of GHC. Then run `./build.sh` to compile, or run `./build.sh clean` to remove the build products. Then to run the demo, run `./fractran`. +You need an installation of GHC. Then run `./build.sh` to compile, or run `./build.sh clean` to remove the build products. The script now builds two binaries: + +- `./fractran` for the original demo flow +- `./fractran-bench` for deterministic benchmark runs + +On systems where only dynamic Haskell package artifacts are installed, `./build.sh` uses `-dynamic` by default so the build succeeds without extra package surgery. To run the original demo, use `./fractran`. + +Example benchmark run: + +```sh +./fractran-bench --program primegame --engine cycle --take 100 +``` + +Available benchmark programs: + +- `primegame` +- `paper` +- `hamming` +- `mult` + +Available benchmark engines: + +- `naive-fast` +- `reg` +- `frac-opt` +- `cycle` +- `compiled` To build for the browser, there are more steps. You need to install docker and run `./build.sh --browser` to first populate `web/gen`. Webpack depends on the JS output from Asterius which gets dumped to that directory. Then cd into `web` and run `yarn` which will install the NPM package dependencies. You then should be able to run `yarn run serve`. diff --git a/build.sh b/build.sh index 9cb33af..e92f23d 100755 --- a/build.sh +++ b/build.sh @@ -19,8 +19,14 @@ if [ "$1" = '--browser' ]; then else if [ "$1" = 'clean' ]; then rm -rf out; + rm -f fractran fractran-bench exit 0 fi mkdir -p out - ghc --make -prof -fprof-auto src/main.hs -isrc -odir out -hidir out -o fractran + GHC_FLAGS="-dynamic" + if [ "$1" = '--profile' ]; then + GHC_FLAGS="-prof -fprof-auto" + fi + ghc --make $GHC_FLAGS src/main.hs -isrc -odir out -hidir out -o fractran + ghc --make $GHC_FLAGS src/bench_main.hs -isrc -odir out -hidir out -o fractran-bench fi diff --git a/src/Bench.hs b/src/Bench.hs new file mode 100644 index 0000000..895c2a7 --- /dev/null +++ b/src/Bench.hs @@ -0,0 +1,459 @@ +module Bench where + +import Control.Exception (SomeException, evaluate, try) +import Data.Array +import Data.List (foldl', intercalate) +import Data.Maybe (fromMaybe) +import qualified Data.Map.Strict as M +import Data.Ratio +import System.CPUTime (getCPUTime) +import System.Exit (die) +import Text.Read (readMaybe) + +import Compiled +import Demo (hamming, mult, paper, primegame) +import Fractran +import Others (naive', regBased) + +data Config = Config + { cfgScenario :: Maybe String + , cfgProgram :: String + , cfgEngine :: String + , cfgInit :: Integer + , cfgTake :: Int + , cfgCycleLen :: Int + , cfgMode :: String + , cfgCheckpointPolicy :: String + , cfgRepeats :: Int + , cfgOutput :: Maybe FilePath + } + +data Scenario = Scenario + { scName :: String + , scProgram :: String + , scInit :: Integer + , scTake :: Int + , scCycleLen :: Int + } + +data RunRecord = RunRecord + { rrScenario :: String + , rrProgram :: String + , rrEngine :: String + , rrMode :: String + , rrCheckpointPolicy :: String + , rrInit :: Integer + , rrLogicalStepsTarget :: Maybe Integer + , rrLogicalStepsReached :: Integer + , rrLogicalStepsOvershoot :: Maybe Integer + , rrEmittedStates :: Int + , rrChecksum :: Maybe Integer + , rrFinalStateHash :: Maybe String + , rrCpuSeconds :: Maybe Double + , rrOk :: Bool + , rrError :: Maybe String + , rrRepeat :: Int + } + +defaultConfig :: Config +defaultConfig = + Config + { cfgScenario = Nothing + , cfgProgram = "primegame" + , cfgEngine = "cycle" + , cfgInit = 2 + , cfgTake = 100 + , cfgCycleLen = 2 + , cfgMode = "logical-steps" + , cfgCheckpointPolicy = "at-least" + , cfgRepeats = 1 + , cfgOutput = Nothing + } + +usage :: String +usage = + unlines + [ "Usage: fractran-bench [--scenario NAME] [--program NAME] [--engine NAME] [--init N] [--take N] [--cycle-len N] [--mode logical-steps|emitted-states] [--checkpoint-policy exact|at-least] [--repeats N] [--output PATH]" + , "" + , "Programs: primegame, paper, hamming, mult" + , "Engines: naive-fast, reg, frac-opt, cycle, compiled, lut" + , "Scenarios: mult_smoke, primegame_small, primegame_medium, primegame_large" + ] + +defaultScenarioName :: Config -> String +defaultScenarioName cfg = + fromMaybe + (cfgProgram cfg ++ "_" ++ cfgMode cfg ++ "_" ++ show (cfgTake cfg)) + (cfgScenario cfg) + +scenarios :: [Scenario] +scenarios = + [ Scenario "mult_smoke" "mult" 2 2 2 + , Scenario "primegame_small" "primegame" 2 1000 2 + , Scenario "primegame_medium" "primegame" 2 10000 2 + , Scenario "primegame_large" "primegame" 2 100000 2 + ] + +lookupScenario :: String -> Either String Scenario +lookupScenario name = + case filter ((== name) . scName) scenarios of + [scenario] -> Right scenario + _ -> Left ("Unknown scenario: " ++ name) + +applyScenario :: Config -> Scenario -> Config +applyScenario cfg scenario = + cfg + { cfgScenario = Just (scName scenario) + , cfgProgram = scProgram scenario + , cfgInit = scInit scenario + , cfgTake = scTake scenario + , cfgCycleLen = scCycleLen scenario + } + +parseArgs :: [String] -> Either String Config +parseArgs = go defaultConfig + where + go cfg [] = Right cfg + go cfg ("--scenario" : value : rest) = + case lookupScenario value of + Right scenario -> go (applyScenario cfg scenario) rest + Left err -> Left err + go cfg ("--program" : value : rest) = go cfg {cfgProgram = value} rest + go cfg ("--engine" : value : rest) = go cfg {cfgEngine = value} rest + go cfg ("--init" : value : rest) = + case readMaybe value of + Just n -> go cfg {cfgInit = n} rest + Nothing -> Left ("Invalid integer for --init: " ++ value) + go cfg ("--take" : value : rest) = + case readMaybe value of + Just n -> go cfg {cfgTake = n} rest + Nothing -> Left ("Invalid integer for --take: " ++ value) + go cfg ("--cycle-len" : value : rest) = + case readMaybe value of + Just n -> go cfg {cfgCycleLen = n} rest + Nothing -> Left ("Invalid integer for --cycle-len: " ++ value) + go cfg ("--mode" : value : rest) = go cfg {cfgMode = value} rest + go cfg ("--checkpoint-policy" : value : rest) = go cfg {cfgCheckpointPolicy = value} rest + go cfg ("--repeats" : value : rest) = + case readMaybe value of + Just n -> go cfg {cfgRepeats = n} rest + Nothing -> Left ("Invalid integer for --repeats: " ++ value) + go cfg ("--output" : value : rest) = go cfg {cfgOutput = Just value} rest + go _ ("--help" : _) = Left usage + go _ ("-h" : _) = Left usage + go _ (flag : _) = Left ("Unknown argument: " ++ flag ++ "\n\n" ++ usage) + +lookupProgram :: String -> Either String [Rational] +lookupProgram name = + case name of + "primegame" -> Right primegame + "paper" -> Right paper + "hamming" -> Right hamming + "mult" -> Right mult + _ -> Left ("Unknown program: " ++ name) + +enginePoints :: Config -> [Rational] -> Either String [(Integer, IntMap)] +enginePoints cfg program = + case cfgEngine cfg of + "naive-fast" -> Right $ zip [1 ..] $ map facmap $ naive' program (cfgInit cfg) + "reg" -> Right $ zip [1 ..] $ regBased program (cfgInit cfg) + "frac-opt" -> Right $ zip [1 ..] $ fracOpt program (cfgInit cfg) + "cycle" -> Right $ stepCount $ cycles (cfgCycleLen cfg) program (cfgInit cfg) + "compiled" -> Right $ zip [1 ..] $ runCompiled compiled (cfgInit cfg) + "lut" -> + case runLut compiled (cfgInit cfg) of + Right states -> Right $ zip [1 ..] states + Left err -> Left err + _ -> Left ("Unknown engine: " ++ cfgEngine cfg) + where + compiled = compileProgram program + +validateConfig :: Config -> Either String () +validateConfig cfg + | cfgTake cfg <= 0 = Left "--take must be positive" + | cfgCycleLen cfg <= 0 = Left "--cycle-len must be positive" + | cfgInit cfg <= 0 = Left "--init must be positive" + | cfgRepeats cfg <= 0 = Left "--repeats must be positive" + | cfgEngine cfg `elem` ["naive-fast", "reg", "frac-opt", "cycle", "compiled", "lut"] = + Right () + | cfgMode cfg `notElem` ["logical-steps", "emitted-states"] = + Left ("Unknown mode: " ++ cfgMode cfg) + | cfgCheckpointPolicy cfg `notElem` ["exact", "at-least"] = + Left ("Unknown checkpoint policy: " ++ cfgCheckpointPolicy cfg) + | otherwise = Left ("Unknown engine: " ++ cfgEngine cfg) + +trimPoints :: Config -> [(Integer, IntMap)] -> [(Integer, IntMap)] +trimPoints cfg = + case cfgMode cfg of + "logical-steps" -> takeUntilLogical (toInteger $ cfgTake cfg) + "emitted-states" -> take (cfgTake cfg) + _ -> take (cfgTake cfg) + +takeUntilLogical :: Integer -> [(Integer, IntMap)] -> [(Integer, IntMap)] +takeUntilLogical _ [] = [] +takeUntilLogical target (point@(logicalSteps, _) : rest) + | logicalSteps >= target = [point] + | otherwise = point : takeUntilLogical target rest + +summarize :: [(Integer, IntMap)] -> (Integer, Int, Maybe Integer, Maybe String) +summarize states = (logicalStepsReached, emittedStates, checksum, finalHash) + where + emittedStates = length states + logicalStepsReached = + if null states + then 0 + else fst (last states) + checksum = + if null states + then Nothing + else Just $ foldl' (\acc (_, im) -> acc + unfmap im) 0 states + finalHash = + if null states + then Nothing + else Just $ show $ stateHash $ snd (last states) + +summarizeCompiledTrace :: CompiledProgram -> [(ExpVec, Integer)] -> (Integer, Int, Maybe Integer, Maybe String) +summarizeCompiledTrace program states = (logicalStepsReached, emittedStates, checksum, finalHash) + where + emittedStates = length states + logicalStepsReached = toInteger emittedStates + checksum = + if null states + then Nothing + else Just $ foldl' (\acc (_, value) -> acc + value) 0 states + finalHash = + if null states + then Nothing + else Just $ show $ expVecStateHash program (fst (last states)) + +stateHash :: IntMap -> Integer +stateHash = foldl' step 1469598103934665603 . M.toAscList + where + step acc (prime, exponent) = + ((acc * 1099511628211) + fromIntegral prime * 1000003 + exponent) + +runOnce :: Config -> Int -> IO RunRecord +runOnce cfg repeatIx = do + case validateConfig cfg of + Left err -> die err + Right () -> pure () + program <- + case lookupProgram (cfgProgram cfg) of + Right p -> pure p + Left err -> die err + let scenarioName = defaultScenarioName cfg + logicalTarget = + case cfgMode cfg of + "logical-steps" -> Just (toInteger $ cfgTake cfg) + _ -> Nothing + compiled = compileProgram program + if cfgEngine cfg == "compiled" + then runCompiledOnce cfg compiled scenarioName logicalTarget repeatIx + else case enginePoints cfg program of + Left err -> + pure $ + RunRecord + { rrScenario = scenarioName + , rrProgram = cfgProgram cfg + , rrEngine = cfgEngine cfg + , rrMode = cfgMode cfg + , rrCheckpointPolicy = cfgCheckpointPolicy cfg + , rrInit = cfgInit cfg + , rrLogicalStepsTarget = logicalTarget + , rrLogicalStepsReached = 0 + , rrLogicalStepsOvershoot = Nothing + , rrEmittedStates = 0 + , rrChecksum = Nothing + , rrFinalStateHash = Nothing + , rrCpuSeconds = Nothing + , rrOk = False + , rrError = Just err + , rrRepeat = repeatIx + } + Right basePoints -> do + let trimmed = trimPoints cfg basePoints + start <- getCPUTime + result <- try (evaluateSummary trimmed) :: IO (Either SomeException (Integer, Int, Maybe Integer, Maybe String)) + end <- getCPUTime + pure $ + case result of + Right (logicalReached, emittedStates, checksum, finalHash) -> + RunRecord + { rrScenario = scenarioName + , rrProgram = cfgProgram cfg + , rrEngine = cfgEngine cfg + , rrMode = cfgMode cfg + , rrCheckpointPolicy = cfgCheckpointPolicy cfg + , rrInit = cfgInit cfg + , rrLogicalStepsTarget = logicalTarget + , rrLogicalStepsReached = logicalReached + , rrLogicalStepsOvershoot = calcOvershoot logicalTarget logicalReached + , rrEmittedStates = emittedStates + , rrChecksum = checksum + , rrFinalStateHash = finalHash + , rrCpuSeconds = Just (fromIntegral (end - start) / 1.0e12) + , rrOk = checkpointSatisfied (cfgCheckpointPolicy cfg) logicalTarget logicalReached + , rrError = Nothing + , rrRepeat = repeatIx + } + Left err -> + RunRecord + { rrScenario = scenarioName + , rrProgram = cfgProgram cfg + , rrEngine = cfgEngine cfg + , rrMode = cfgMode cfg + , rrCheckpointPolicy = cfgCheckpointPolicy cfg + , rrInit = cfgInit cfg + , rrLogicalStepsTarget = logicalTarget + , rrLogicalStepsReached = 0 + , rrLogicalStepsOvershoot = Nothing + , rrEmittedStates = 0 + , rrChecksum = Nothing + , rrFinalStateHash = Nothing + , rrCpuSeconds = Just (fromIntegral (end - start) / 1.0e12) + , rrOk = False + , rrError = Just (show err) + , rrRepeat = repeatIx + } + +runCompiledOnce :: Config -> CompiledProgram -> String -> Maybe Integer -> Int -> IO RunRecord +runCompiledOnce cfg compiled scenarioName logicalTarget repeatIx = do + let states = trimCompiledTrace cfg (runCompiledTrace compiled (cfgInit cfg)) + start <- getCPUTime + result <- try (evaluateCompiledSummary compiled states) :: IO (Either SomeException (Integer, Int, Maybe Integer, Maybe String)) + end <- getCPUTime + pure $ + case result of + Right (logicalReached, emittedStates, checksum, finalHash) -> + RunRecord + { rrScenario = scenarioName + , rrProgram = cfgProgram cfg + , rrEngine = cfgEngine cfg + , rrMode = cfgMode cfg + , rrCheckpointPolicy = cfgCheckpointPolicy cfg + , rrInit = cfgInit cfg + , rrLogicalStepsTarget = logicalTarget + , rrLogicalStepsReached = logicalReached + , rrLogicalStepsOvershoot = calcOvershoot logicalTarget logicalReached + , rrEmittedStates = emittedStates + , rrChecksum = checksum + , rrFinalStateHash = finalHash + , rrCpuSeconds = Just (fromIntegral (end - start) / 1.0e12) + , rrOk = checkpointSatisfied (cfgCheckpointPolicy cfg) logicalTarget logicalReached + , rrError = Nothing + , rrRepeat = repeatIx + } + Left err -> + RunRecord + { rrScenario = scenarioName + , rrProgram = cfgProgram cfg + , rrEngine = cfgEngine cfg + , rrMode = cfgMode cfg + , rrCheckpointPolicy = cfgCheckpointPolicy cfg + , rrInit = cfgInit cfg + , rrLogicalStepsTarget = logicalTarget + , rrLogicalStepsReached = 0 + , rrLogicalStepsOvershoot = Nothing + , rrEmittedStates = 0 + , rrChecksum = Nothing + , rrFinalStateHash = Nothing + , rrCpuSeconds = Just (fromIntegral (end - start) / 1.0e12) + , rrOk = False + , rrError = Just (show err) + , rrRepeat = repeatIx + } + +runBench :: Config -> IO () +runBench cfg = do + records <- mapM (runOnce cfg) [1 .. cfgRepeats cfg] + mapM_ emitRecord records + case cfgOutput cfg of + Just path -> appendFile path (unlines $ map toJsonLine records) + Nothing -> pure () + +emitRecord :: RunRecord -> IO () +emitRecord record = do + putStrLn ("scenario=" ++ rrScenario record) + putStrLn ("program=" ++ rrProgram record) + putStrLn ("engine=" ++ rrEngine record) + putStrLn ("mode=" ++ rrMode record) + putStrLn ("checkpoint_policy=" ++ rrCheckpointPolicy record) + putStrLn ("init=" ++ show (rrInit record)) + putStrLn ("logical_steps_target=" ++ maybe "null" show (rrLogicalStepsTarget record)) + putStrLn ("logical_steps_reached=" ++ show (rrLogicalStepsReached record)) + putStrLn ("logical_steps_overshoot=" ++ maybe "null" show (rrLogicalStepsOvershoot record)) + putStrLn ("emitted_states=" ++ show (rrEmittedStates record)) + putStrLn ("checksum=" ++ maybe "null" show (rrChecksum record)) + putStrLn ("final_state_hash=" ++ maybe "null" id (rrFinalStateHash record)) + putStrLn ("cpu_seconds=" ++ maybe "null" show (rrCpuSeconds record)) + putStrLn ("ok=" ++ show (rrOk record)) + putStrLn ("error=" ++ maybe "null" id (rrError record)) + putStrLn ("repeat=" ++ show (rrRepeat record)) + +evaluateSummary :: [(Integer, IntMap)] -> IO (Integer, Int, Maybe Integer, Maybe String) +evaluateSummary states = evaluate forced + where + forced = + let summary@(logicalReached, emittedStates, checksum, finalHash) = summarize states + in logicalReached `seq` emittedStates `seq` checksum `seq` finalHash `seq` summary + +evaluateCompiledSummary :: CompiledProgram -> [(ExpVec, Integer)] -> IO (Integer, Int, Maybe Integer, Maybe String) +evaluateCompiledSummary program states = evaluate forced + where + forced = + let summary@(logicalReached, emittedStates, checksum, finalHash) = summarizeCompiledTrace program states + in logicalReached `seq` emittedStates `seq` checksum `seq` finalHash `seq` summary + +trimCompiledTrace :: Config -> [(ExpVec, Integer)] -> [(ExpVec, Integer)] +trimCompiledTrace cfg = + case cfgMode cfg of + "logical-steps" -> take (cfgTake cfg) + "emitted-states" -> take (cfgTake cfg) + _ -> take (cfgTake cfg) + +toJsonLine :: RunRecord -> String +toJsonLine record = + "{" ++ intercalate "," fields ++ "}" + where + fields = + [ jsonField "scenario" (jsonString $ rrScenario record) + , jsonField "program" (jsonString $ rrProgram record) + , jsonField "engine" (jsonString $ rrEngine record) + , jsonField "mode" (jsonString $ rrMode record) + , jsonField "checkpoint_policy" (jsonString $ rrCheckpointPolicy record) + , jsonField "init" (show $ rrInit record) + , jsonField "logical_steps_target" (maybe "null" show $ rrLogicalStepsTarget record) + , jsonField "logical_steps_reached" (show $ rrLogicalStepsReached record) + , jsonField "logical_steps_overshoot" (maybe "null" show $ rrLogicalStepsOvershoot record) + , jsonField "emitted_states" (show $ rrEmittedStates record) + , jsonField "checksum" (maybe "null" show $ rrChecksum record) + , jsonField "final_state_hash" (maybe "null" jsonString $ rrFinalStateHash record) + , jsonField "cpu_seconds" (maybe "null" show $ rrCpuSeconds record) + , jsonField "ok" (if rrOk record then "true" else "false") + , jsonField "error" (maybe "null" jsonString $ rrError record) + , jsonField "repeat" (show $ rrRepeat record) + ] + +jsonField :: String -> String -> String +jsonField key value = jsonString key ++ ":" ++ value + +jsonString :: String -> String +jsonString value = "\"" ++ concatMap escapeChar value ++ "\"" + +escapeChar :: Char -> String +escapeChar '"' = "\\\"" +escapeChar '\\' = "\\\\" +escapeChar '\n' = "\\n" +escapeChar '\r' = "\\r" +escapeChar '\t' = "\\t" +escapeChar c = [c] + +checkpointSatisfied :: String -> Maybe Integer -> Integer -> Bool +checkpointSatisfied _ Nothing _ = True +checkpointSatisfied "exact" (Just target) reached = reached == target +checkpointSatisfied "at-least" (Just target) reached = reached >= target +checkpointSatisfied _ _ _ = False + +calcOvershoot :: Maybe Integer -> Integer -> Maybe Integer +calcOvershoot Nothing _ = Nothing +calcOvershoot (Just target) reached = Just (max 0 (reached - target)) diff --git a/src/Compiled.hs b/src/Compiled.hs new file mode 100644 index 0000000..88ba22d --- /dev/null +++ b/src/Compiled.hs @@ -0,0 +1,267 @@ +module Compiled where + +import Data.Array +import Data.Bits ((.&.), (.|.), shiftL) +import Data.List (foldl', nub, sort) +import Data.Ratio +import qualified Data.Map.Strict as M + +import Fractran + +type ExpVec = Array Int Integer + +data CompiledRule = CompiledRule + { compiledNum :: IntMap + , compiledDen :: IntMap + , compiledDenIx :: [(Int, Integer)] + , compiledReqMask :: Int + , compiledDelta :: ExpVec + , compiledNumValue :: Integer + , compiledDenValue :: Integer + } + +data LutProgram = LutProgram + { lutRuleIndex :: Array Int Int + } + +data CompiledProgram = CompiledProgram + { cpPrimes :: Array Int Int + , cpPrimeIndex :: M.Map Int Int + , cpRules :: Array Int CompiledRule + , cpInitialRuleOrder :: [Int] + , cpRuleOpts :: Array Int [Int] + , cpLut :: Maybe LutProgram + } + +compileProgram :: [Rational] -> CompiledProgram +compileProgram fracs = + CompiledProgram + { cpPrimes = primeArray + , cpPrimeIndex = primeIndex + , cpRules = ruleArray + , cpInitialRuleOrder = ruleIndices + , cpRuleOpts = ruleOpts + , cpLut = buildLut primeArray compiledRules + } + where + fmaps = [(facmap $ numerator f, facmap $ denominator f) | f <- fracs] + primeList = + sort $ + nub $ + concatMap (\(num, den) -> M.keys num ++ M.keys den) fmaps + primeArray = listArray (0, length primeList - 1) primeList + primeIndex = M.fromList $ zip primeList [0 ..] + compiledRules = map compileRule fmaps + ruleIndices = [0 .. length compiledRules - 1] + ruleArray = listArray (0, length compiledRules - 1) compiledRules + ruleOpts = listArray (bounds ruleArray) [ruleOpt ix | ix <- indices ruleArray] + compileRule (num, den) = + CompiledRule + { compiledNum = num + , compiledDen = den + , compiledDenIx = + [ (primeIndex M.! prime, needed) + | (prime, needed) <- M.assocs den + ] + , compiledReqMask = + foldl' + (\mask (prime, needed) -> + if needed > 0 + then mask .|. (1 `shiftL` (primeIndex M.! prime)) + else mask) + 0 + (M.assocs den) + , compiledDelta = deltaArray primeArray num den + , compiledNumValue = unfmap num + , compiledDenValue = unfmap den + } + ruleOpt ix = preOpt ix ++ [ix .. snd (bounds ruleArray)] + preOpt ix = + [ preIx + | preIx <- [0 .. ix - 1] + , couldPre (compiledNum (ruleArray ! ix)) (compiledDen (ruleArray ! preIx)) + ] + couldPre num den = not (M.null (M.intersection num den)) + +deltaArray :: Array Int Int -> IntMap -> IntMap -> ExpVec +deltaArray basis num den = listArray bounds entries + where + bounds = boundsOf basis + entries = + [ M.findWithDefault 0 prime num - M.findWithDefault 0 prime den + | (_, prime) <- assocs basis + ] + +boundsOf :: Array Int a -> (Int, Int) +boundsOf = bounds + +encodeInteger :: CompiledProgram -> Integer -> ExpVec +encodeInteger program n = encodeIntMap program (facmap n) + +encodeIntMap :: CompiledProgram -> IntMap -> ExpVec +encodeIntMap program exponents = + listArray (bounds basis) $ + [ M.findWithDefault 0 prime exponents + | (_, prime) <- assocs basis + ] + where + basis = cpPrimes program + +decodeExpVec :: CompiledProgram -> ExpVec -> IntMap +decodeExpVec program exponents = + M.fromList + [ (prime, pow) + | (ix, pow) <- assocs exponents + , pow /= 0 + , let prime = cpPrimes program ! ix + ] + +stepCompiled :: CompiledProgram -> ExpVec -> Maybe ExpVec +stepCompiled program state = + case firstCompatible (cpInitialRuleOrder program) of + Just rule -> Just (applyRule state rule) + Nothing -> Nothing + where + rules = cpRules program + firstCompatible [] = Nothing + firstCompatible (ruleIx : rest) + | ruleCompatible state rule = Just rule + | otherwise = firstCompatible rest + where + rule = rules ! ruleIx + +stepLut :: CompiledProgram -> ExpVec -> Either String (Maybe ExpVec) +stepLut program state = + case cpLut program of + Nothing -> Left "lut incompatible with non-binary denominator thresholds" + Just lut -> + let mask = stateMask state + ruleIx = lutRuleIndex lut ! mask + in if ruleIx < 0 + then Right Nothing + else Right $ Just (applyRule state (cpRules program ! ruleIx)) + +ruleCompatible :: ExpVec -> CompiledRule -> Bool +ruleCompatible state rule = all enough (compiledDenIx rule) + where + enough (ix, needed) = state ! ix >= needed + +applyRule :: ExpVec -> CompiledRule -> ExpVec +applyRule state rule = listArray (bounds state) (zipWith (+) (elems state) (elems (compiledDelta rule))) + where + -- The compiled basis is small in the current workloads, so element-wise + -- zipping avoids repeated array indexing in the hot path. + +runCompiled :: CompiledProgram -> Integer -> [IntMap] +runCompiled program initN = unfold (cpInitialRuleOrder program) (encodeInteger program initN) + where + rules = cpRules program + opts = cpRuleOpts program + unfold candidateRules state = + case firstCompatible candidateRules state of + Just (ruleIx, next) -> decodeExpVec program next : unfold (opts ! ruleIx) next + Nothing -> [] + firstCompatible [] _ = Nothing + firstCompatible (ruleIx : rest) state + | ruleCompatible state rule = Just (ruleIx, applyRule state rule) + | otherwise = firstCompatible rest state + where + rule = rules ! ruleIx + +runCompiledExpVec :: CompiledProgram -> Integer -> [ExpVec] +runCompiledExpVec program initN = unfold (cpInitialRuleOrder program) (encodeInteger program initN) + where + rules = cpRules program + opts = cpRuleOpts program + unfold candidateRules state = + case firstCompatible candidateRules state of + Just (ruleIx, next) -> next : unfold (opts ! ruleIx) next + Nothing -> [] + firstCompatible [] _ = Nothing + firstCompatible (ruleIx : rest) state + | ruleCompatible state rule = Just (ruleIx, applyRule state rule) + | otherwise = firstCompatible rest state + where + rule = rules ! ruleIx + +runCompiledTrace :: CompiledProgram -> Integer -> [(ExpVec, Integer)] +runCompiledTrace program initN = unfold (cpInitialRuleOrder program) initN (encodeInteger program initN) + where + rules = cpRules program + opts = cpRuleOpts program + unfold candidateRules currentValue state = + case firstCompatible candidateRules state of + Just (ruleIx, next) -> + let rule = rules ! ruleIx + nextValue = (currentValue * compiledNumValue rule) `div` compiledDenValue rule + in (next, nextValue) : unfold (opts ! ruleIx) nextValue next + Nothing -> [] + firstCompatible [] _ = Nothing + firstCompatible (ruleIx : rest) state + | ruleCompatible state rule = Just (ruleIx, applyRule state rule) + | otherwise = firstCompatible rest state + where + rule = rules ! ruleIx + +unfExpVec :: CompiledProgram -> ExpVec -> Integer +unfExpVec program exponents = + foldl' + (\prod (ix, pow) -> + if pow == 0 + then prod + else prod * toInteger (cpPrimes program ! ix) ^ pow) + 1 + (assocs exponents) + +expVecStateHash :: CompiledProgram -> ExpVec -> Integer +expVecStateHash program = + foldl' step 1469598103934665603 . assocs + where + step acc (ix, exponent) + | exponent == 0 = acc + | otherwise = + let prime = cpPrimes program ! ix + in ((acc * 1099511628211) + fromIntegral prime * 1000003 + exponent) + +runLut :: CompiledProgram -> Integer -> Either String [IntMap] +runLut program initN = + case cpLut program of + Nothing -> Left "lut incompatible with non-binary denominator thresholds" + Just _ -> Right (unfold (encodeInteger program initN)) + where + unfold state = + case stepLut program state of + Left _ -> [] + Right (Just next) -> decodeExpVec program next : unfold next + Right Nothing -> [] + +lutCompatible :: CompiledProgram -> Bool +lutCompatible = maybe False (const True) . cpLut + +buildLut :: Array Int Int -> [CompiledRule] -> Maybe LutProgram +buildLut primeArray rules + | any hasThresholdGtOne rules = Nothing + | primeCount > finiteBitBudget = Nothing + | otherwise = Just $ LutProgram {lutRuleIndex = table} + where + primeCount = rangeSize (bounds primeArray) + finiteBitBudget = 20 + tableBounds = (0, (1 `shiftL` primeCount) - 1) + table = listArray tableBounds [firstApplicable mask | mask <- range tableBounds] + hasThresholdGtOne rule = any (\(_, needed) -> needed > 1) (compiledDenIx rule) + firstApplicable mask = go 0 rules + where + go _ [] = -1 + go ix (rule : rest) + | ruleReqSatisfied mask rule = ix + | otherwise = go (ix + 1) rest + +ruleReqSatisfied :: Int -> CompiledRule -> Bool +ruleReqSatisfied mask rule = (mask .&. compiledReqMask rule) == compiledReqMask rule + +stateMask :: ExpVec -> Int +stateMask state = + foldl' + (\mask ix -> if state ! ix > 0 then mask .|. (1 `shiftL` ix) else mask) + 0 + (indices state) diff --git a/src/bench_main.hs b/src/bench_main.hs new file mode 100644 index 0000000..c21465f --- /dev/null +++ b/src/bench_main.hs @@ -0,0 +1,13 @@ +module Main where + +import System.Environment (getArgs) +import System.Exit (die) + +import Bench + +main :: IO () +main = do + args <- getArgs + case parseArgs args of + Right cfg -> runBench cfg + Left msg -> die msg