-- | The JIT's entry points for the rest of the runtime, and the handle
-- that holds its state. See unison-runtime/src/Unison/Runtime/JIT/design.md.
module Unison.Runtime.JIT
  ( JIT,
    newJIT,
    typeNumbers,
    readConfig,
    jitConfig,
    jitExits,
    jitFrames,
    jitPool,
    jitTracing,
    jitStats,
    initialNativeCount,
    stackSlots,
    loadJIT,
    startJIT,
    jitCompileGroup,
    jitRequestGroup,
    jitRequestCell,
    noteAdHocExit,
    registerTypeNumbers,
    printJITStats,
    noteOutput,
  )
where

import Control.Concurrent (forkOn, getNumCapabilities, myThreadId, threadCapability, yield)
import Control.Concurrent.STM (TBQueue, TVar, atomically, isFullTBQueue, newTBQueueIO, readTBQueue, readTVarIO, writeTBQueue)
import Control.Exception (SomeException, evaluate, try)
import Control.Monad (foldM, forM, forM_, unless, void, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, withExceptT)
import Data.IORef
import Data.List (sortOn)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Word (Word64)
import Foreign.Ptr (FunPtr, Ptr, castFunPtrToPtr, nullPtr)
import GHC.Clock (getMonotonicTimeNSec)
import System.IO (hFlush, stdout)
import System.Info (os)
import System.Timeout (timeout)
import Unison.Reference (Reference)
import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..))
import Unison.Runtime.JIT.Codegen (CtxOffsets (..), RtsFacts (..))
import Unison.Runtime.JIT.Compile
import Unison.Runtime.JIT.Config
import Unison.Runtime.JIT.Estimate (Estimate (..), judge)
import Unison.Runtime.JIT.Exits
import Unison.Runtime.JIT.Frames (Frames)
import Unison.Runtime.JIT.Helpers (exitIR, helpersIR)
import Unison.Runtime.JIT.LLVM
import Unison.Runtime.JIT.Layout (probeArrays, probeBytes, probeCompare, probeEnv, probeLayouts, probeLists, probeMurmur, probeNames, probeRecords, probeTexts)
import Unison.Runtime.JIT.Native (configureNative, ctxLayout, helperAddresses, murmurCAddress, rtsFacts, tableAddresses, ucmpCAddress)
import Unison.Runtime.JIT.Pool (Pool)
import Unison.Runtime.MCode (CombIx (..), GComb (..), GCombInfo (..), NativeCell, bumpNativeCount, claimNativeCell, combDeps, nativeCellRequested, noNativeCell, prettyIns, prettySection, readNativeCode, readNativeCount, releaseNativeCell, takeNativeCell, writeNativeCount)
import Unison.Runtime.Stack (MCombs, defaultStackSlots)
import Unison.Util.EnumContainers qualified as EC

-- | The JIT: its settings and everything it keeps while the process runs.
-- There is one per process, made by ucm at startup ('newJIT') and given to
-- every runtime it starts, since what the JIT compiles is shared: generated
-- code refers to the exits and frames tables and the constant pool by
-- index, and native code in one module calls into another directly. Each
-- code cache carries the handle (CCache's @jit@), which is how the
-- interpreter reaches it.
data JIT = JIT
  { JIT -> Compiler
jitCompiler :: !Compiler,
    -- | the numbers the code cache gives types (abilities among them),
    -- with their references: the type part of a packed tag, which the one
    -- match arm that compares a whole tag needs (Codegen's
    -- 'envTypeNumbers'). No other declaration of a type reaches the
    -- generator: field counts come from the match arms and the objects.
    JIT -> IORef (EnumMap Word64 Reference)
jitTypeNumbers :: !(IORef (EC.EnumMap Word64 Reference)),
    -- | set once by 'initJIT' when everything checks out; Nothing means off
    JIT -> IORef (Maybe JITState)
jitState :: !(IORef (Maybe JITState)),
    -- | set once a load has been tried, so that it is tried once only: a
    -- failure would be the same the second time, and would print again
    JIT -> IORef (Maybe (Either [[Char]] [Char]))
jitInitTried :: !(IORef (Maybe (Either [String] String))),
    -- | what the interpreter asks the compile thread for; bounded, so a
    -- burst of requests costs nothing but the requests: one that doesn't
    -- fit is dropped, and made again if the code stays hot
    JIT -> TBQueue Request
jitRequests :: !(TBQueue Request),
    JIT -> IORef Bool
jitCompileThreadStarted :: !(IORef Bool),
    -- | the re-entry functions each group may still get because of ad
    -- hoc exits, and what those exits asked for (see 'noteAdHocExit')
    JIT -> IORef AdHoc
jitAdHoc :: !(IORef AdHoc)
  }

data AdHoc = AdHoc
  { -- | by group number; absent means the full allowance
    AdHoc -> EnumMap Word64 Int
ahBudgets :: !(EC.EnumMap Word64 Int),
    -- | re-entry functions asked for because of ad hoc exits
    AdHoc -> Int
ahRequested :: !Int,
    -- | ad hoc exits through an uncompiled Let of a group at its cap
    AdHoc -> Int
ahRefused :: !Int
  }

-- | A JIT with these settings, not started: nothing is loaded or compiled
-- until 'loadJIT' or 'startJIT'. In the off mode it is inert, and the
-- runtime's calls into it return at once.
newJIT :: Config -> IO JIT
newJIT :: Config -> IO JIT
newJIT Config
config =
  Compiler
-> IORef (EnumMap Word64 Reference)
-> IORef (Maybe JITState)
-> IORef (Maybe (Either [[Char]] [Char]))
-> TBQueue Request
-> IORef Bool
-> IORef AdHoc
-> JIT
JIT
    (Compiler
 -> IORef (EnumMap Word64 Reference)
 -> IORef (Maybe JITState)
 -> IORef (Maybe (Either [[Char]] [Char]))
 -> TBQueue Request
 -> IORef Bool
 -> IORef AdHoc
 -> JIT)
-> IO Compiler
-> IO
     (IORef (EnumMap Word64 Reference)
      -> IORef (Maybe JITState)
      -> IORef (Maybe (Either [[Char]] [Char]))
      -> TBQueue Request
      -> IORef Bool
      -> IORef AdHoc
      -> JIT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> IO Compiler
newCompiler Config
config
    IO
  (IORef (EnumMap Word64 Reference)
   -> IORef (Maybe JITState)
   -> IORef (Maybe (Either [[Char]] [Char]))
   -> TBQueue Request
   -> IORef Bool
   -> IORef AdHoc
   -> JIT)
-> IO (IORef (EnumMap Word64 Reference))
-> IO
     (IORef (Maybe JITState)
      -> IORef (Maybe (Either [[Char]] [Char]))
      -> TBQueue Request
      -> IORef Bool
      -> IORef AdHoc
      -> JIT)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EnumMap Word64 Reference -> IO (IORef (EnumMap Word64 Reference))
forall a. a -> IO (IORef a)
newIORef ([(Word64, Reference)] -> EnumMap Word64 Reference
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList [])
    IO
  (IORef (Maybe JITState)
   -> IORef (Maybe (Either [[Char]] [Char]))
   -> TBQueue Request
   -> IORef Bool
   -> IORef AdHoc
   -> JIT)
-> IO (IORef (Maybe JITState))
-> IO
     (IORef (Maybe (Either [[Char]] [Char]))
      -> TBQueue Request -> IORef Bool -> IORef AdHoc -> JIT)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe JITState -> IO (IORef (Maybe JITState))
forall a. a -> IO (IORef a)
newIORef Maybe JITState
forall a. Maybe a
Nothing
    IO
  (IORef (Maybe (Either [[Char]] [Char]))
   -> TBQueue Request -> IORef Bool -> IORef AdHoc -> JIT)
-> IO (IORef (Maybe (Either [[Char]] [Char])))
-> IO (TBQueue Request -> IORef Bool -> IORef AdHoc -> JIT)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Either [[Char]] [Char])
-> IO (IORef (Maybe (Either [[Char]] [Char])))
forall a. a -> IO (IORef a)
newIORef Maybe (Either [[Char]] [Char])
forall a. Maybe a
Nothing
    IO (TBQueue Request -> IORef Bool -> IORef AdHoc -> JIT)
-> IO (TBQueue Request) -> IO (IORef Bool -> IORef AdHoc -> JIT)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> IO (TBQueue Request)
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
256
    IO (IORef Bool -> IORef AdHoc -> JIT)
-> IO (IORef Bool) -> IO (IORef AdHoc -> JIT)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    IO (IORef AdHoc -> JIT) -> IO (IORef AdHoc) -> IO JIT
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AdHoc -> IO (IORef AdHoc)
forall a. a -> IO (IORef a)
newIORef (EnumMap Word64 Int -> Int -> Int -> AdHoc
AdHoc ([(Word64, Int)] -> EnumMap Word64 Int
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList []) Int
0 Int
0)

jitConfig :: JIT -> Config
jitConfig :: JIT -> Config
jitConfig = Compiler -> Config
cConfig (Compiler -> Config) -> (JIT -> Compiler) -> JIT -> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Compiler
jitCompiler

jitExits :: JIT -> Exits
jitExits :: JIT -> Exits
jitExits = Compiler -> Exits
cExits (Compiler -> Exits) -> (JIT -> Compiler) -> JIT -> Exits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Compiler
jitCompiler

jitFrames :: JIT -> Frames
jitFrames :: JIT -> Frames
jitFrames = Compiler -> Frames
cFrames (Compiler -> Frames) -> (JIT -> Compiler) -> JIT -> Frames
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Compiler
jitCompiler

jitPool :: JIT -> Pool
jitPool :: JIT -> Pool
jitPool = Compiler -> Pool
cPool (Compiler -> Pool) -> (JIT -> Compiler) -> JIT -> Pool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Compiler
jitCompiler

-- | Whether every transition between native code and the interpreter is
-- logged (@UNISON_JIT_TRACE@).
jitTracing :: JIT -> Bool
jitTracing :: JIT -> Bool
jitTracing = Config -> Bool
trace (Config -> Bool) -> (JIT -> Config) -> JIT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Config
jitConfig

-- | Whether entries and exits are counted (@UNISON_JIT_STATS@).
jitStats :: JIT -> Bool
jitStats :: JIT -> Bool
jitStats = Config -> Bool
stats (Config -> Bool) -> (JIT -> Config) -> JIT -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Config
jitConfig

-- | The count a combinator's cell starts with: minus the threshold in the
-- @on@ mode, zero (never hot) otherwise.
initialNativeCount :: JIT -> Int
initialNativeCount :: JIT -> Int
initialNativeCount JIT
jit = case Config -> Mode
mode (JIT -> Config
jitConfig JIT
jit) of
  Mode
On -> Int -> Int
forall a. Num a => a -> a
negate (Config -> Int
threshold (JIT -> Config
jitConfig JIT
jit))
  Mode
_ -> Int
0

-- | The slots a fresh Unison stack has: the stress mode @ustack=N@ makes
-- it tiny, so that growing the stack is exercised constantly.
stackSlots :: JIT -> Int
stackSlots :: JIT -> Int
stackSlots = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultStackSlots (Maybe Int -> Int) -> (JIT -> Maybe Int) -> JIT -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Maybe Int
stressStack (Config -> Maybe Int) -> (JIT -> Config) -> JIT -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> Config
jitConfig

-- | Records the type numbering of the code cache. Called when types are
-- numbered: for the builtins at startup, and whenever code is loaded.
registerTypeNumbers :: JIT -> EC.EnumMap Word64 Reference -> IO ()
registerTypeNumbers :: JIT -> EnumMap Word64 Reference -> IO ()
registerTypeNumbers JIT
jit EnumMap Word64 Reference
m = IORef (EnumMap Word64 Reference)
-> (EnumMap Word64 Reference -> (EnumMap Word64 Reference, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (JIT -> IORef (EnumMap Word64 Reference)
jitTypeNumbers JIT
jit) (\EnumMap Word64 Reference
old -> (EnumMap Word64 Reference
m EnumMap Word64 Reference
-> EnumMap Word64 Reference -> EnumMap Word64 Reference
forall a. Semigroup a => a -> a -> a
<> EnumMap Word64 Reference
old, ()))

-- | The type reference each type number stands for, as the cache numbers
-- them.
typeNumbers :: JIT -> IO (EC.EnumMap Word64 Reference)
typeNumbers :: JIT -> IO (EnumMap Word64 Reference)
typeNumbers = IORef (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. IORef a -> IO a
readIORef (IORef (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference))
-> (JIT -> IORef (EnumMap Word64 Reference))
-> JIT
-> IO (EnumMap Word64 Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JIT -> IORef (EnumMap Word64 Reference)
jitTypeNumbers

-- | Gets the JIT going if it is enabled. Called by each runtime as it
-- starts. LLVM is normally loaded already, by 'loadJIT' at ucm's startup;
-- if not (another host of the runtime), eager mode loads it here and
-- @on@ mode on the compile thread, when the first request arrives.
startJIT :: JIT -> IO ()
startJIT :: JIT -> IO ()
startJIT JIT
jit = case Config -> Mode
mode (JIT -> Config
jitConfig JIT
jit) of
  Mode
Off -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Mode
Eager -> IO (Either [[Char]] [Char]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JIT -> IO (Either [[Char]] [Char])
initJIT JIT
jit)
  Mode
On -> do
    Bool
first <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (JIT -> IORef Bool
jitCompileThreadStarted JIT
jit) (\Bool
started -> (Bool
True, Bool -> Bool
not Bool
started))
    -- On a capability other than this thread's, so that the compile
    -- thread and the interpreter don't slow each other down.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
first (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (Int
cap, Bool
_) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
      Int
n <- IO Int
getNumCapabilities
      IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> IO () -> IO ThreadId
forkOn ((Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n) (JIT -> IO ()
compileThread JIT
jit))

-- | Loads LLVM at startup, when the JIT is turned on, and says how it
-- went: Nothing when the JIT is off, otherwise whether it is activated,
-- and if not, lines explaining why. Whatever the answer, the program runs:
-- without the JIT everything is interpreted.
loadJIT :: JIT -> IO (Maybe (Either [String] String))
loadJIT :: JIT -> IO (Maybe (Either [[Char]] [Char]))
loadJIT JIT
jit = case Config -> Mode
mode (JIT -> Config
jitConfig JIT
jit) of
  Mode
Off -> Maybe (Either [[Char]] [Char])
-> IO (Maybe (Either [[Char]] [Char]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either [[Char]] [Char])
forall a. Maybe a
Nothing
  Mode
_ -> Either [[Char]] [Char] -> Maybe (Either [[Char]] [Char])
forall a. a -> Maybe a
Just (Either [[Char]] [Char] -> Maybe (Either [[Char]] [Char]))
-> IO (Either [[Char]] [Char])
-> IO (Maybe (Either [[Char]] [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JIT -> IO (Either [[Char]] [Char])
initJIT JIT
jit

-- | Loads LLVM, starts the JIT and probes the runtime, the first time it
-- is called; later calls return the first outcome. On success 'jitState'
-- is set and the result names the LLVM loaded; if anything is wrong the
-- JIT stays off and the result says why, in lines meant for the user.
initJIT :: JIT -> IO (Either [String] String)
initJIT :: JIT -> IO (Either [[Char]] [Char])
initJIT JIT
jit =
  IORef (Maybe (Either [[Char]] [Char]))
-> IO (Maybe (Either [[Char]] [Char]))
forall a. IORef a -> IO a
readIORef (JIT -> IORef (Maybe (Either [[Char]] [Char]))
jitInitTried JIT
jit) IO (Maybe (Either [[Char]] [Char]))
-> (Maybe (Either [[Char]] [Char]) -> IO (Either [[Char]] [Char]))
-> IO (Either [[Char]] [Char])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Either [[Char]] [Char]
r -> Either [[Char]] [Char] -> IO (Either [[Char]] [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either [[Char]] [Char]
r
    Maybe (Either [[Char]] [Char])
Nothing -> do
      Either [[Char]] [Char]
r <- JIT -> IO (Either [[Char]] [Char])
initJIT' JIT
jit
      IORef (Maybe (Either [[Char]] [Char]))
-> Maybe (Either [[Char]] [Char]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (JIT -> IORef (Maybe (Either [[Char]] [Char]))
jitInitTried JIT
jit) (Either [[Char]] [Char] -> Maybe (Either [[Char]] [Char])
forall a. a -> Maybe a
Just Either [[Char]] [Char]
r)
      ([[Char]] -> IO ())
-> ([Char] -> IO ()) -> Either [[Char]] [Char] -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> [Char] -> IO ()
jitLog Config
config)) (Config -> [Char] -> IO ()
jitLog Config
config) Either [[Char]] [Char]
r
      pure Either [[Char]] [Char]
r
  where
    config :: Config
config = JIT -> Config
jitConfig JIT
jit

initJIT' :: JIT -> IO (Either [String] String)
initJIT' :: JIT -> IO (Either [[Char]] [Char])
initJIT' JIT
jit = ExceptT [[Char]] IO [Char] -> IO (Either [[Char]] [Char])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [[Char]] IO [Char] -> IO (Either [[Char]] [Char]))
-> ExceptT [[Char]] IO [Char] -> IO (Either [[Char]] [Char])
forall a b. (a -> b) -> a -> b
$ do
  ([Char]
version, [Char]
path) <-
    (LoadFailure -> [[Char]])
-> ExceptT LoadFailure IO ([Char], [Char])
-> ExceptT [[Char]] IO ([Char], [Char])
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT
      ( \case
          NotFound [[Char]]
tried -> ([Char]
"JIT compilation needs LLVM version >= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
minLLVM [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", searched these locations:") [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [[Char]]
tried
          InitError [Char]
e -> [[Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; the JIT is off"]
      )
      (IO (Either LoadFailure ([Char], [Char]))
-> ExceptT LoadFailure IO ([Char], [Char])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either LoadFailure ([Char], [Char]))
initLLVM)
  -- The closure layouts, and every helper checked against the interpreter:
  -- the list helpers are part of the generated code's contract too, and
  -- bytes go before texts because the text checks build bytes (toUtf8).
  Layouts
ls <- ExceptT [Char] IO Layouts -> ExceptT [[Char]] IO Layouts
forall {a}. ExceptT [Char] IO a -> ExceptT [[Char]] IO a
off (ExceptT [Char] IO Layouts -> ExceptT [[Char]] IO Layouts)
-> ExceptT [Char] IO Layouts -> ExceptT [[Char]] IO Layouts
forall a b. (a -> b) -> a -> b
$ do
    Layouts
ls <- IO (Either [Char] Layouts) -> ExceptT [Char] IO Layouts
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either [Char] Layouts)
probeLayouts
    [Char] -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
"list helper checks" (IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> Int -> IO (Either [Char] ())
probeLists Layouts
ls (Config -> Int
stressLists Config
config)))
    [Char] -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
"bytes helper checks" (IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> Int -> IO (Either [Char] ())
probeBytes Layouts
ls (Config -> Int
stressBytes Config
config)))
    [Char] -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
"text helper checks" (IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> Int -> IO (Either [Char] ())
probeTexts Layouts
ls (Config -> Int
stressTexts Config
config)))
    IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> IO (Either [Char] ())
probeArrays Layouts
ls)
    IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> IO (Either [Char] ())
probeMurmur Layouts
ls)
    IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> IO (Either [Char] ())
probeCompare Layouts
ls)
    IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either [Char] ())
probeEnv
    IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> IO (Either [Char] ())
probeRecords Layouts
ls)
    IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Layouts -> IO (Either [Char] ())
probeNames Layouts
ls)
    pure Layouts
ls
  CtxOffsets
ctx <-
    IO ([Int], Int) -> ExceptT [[Char]] IO ([Int], Int)
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ([Int], Int)
ctxLayout ExceptT [[Char]] IO ([Int], Int)
-> (([Int], Int) -> ExceptT [[Char]] IO CtxOffsets)
-> ExceptT [[Char]] IO CtxOffsets
forall a b.
ExceptT [[Char]] IO a
-> (a -> ExceptT [[Char]] IO b) -> ExceptT [[Char]] IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ([Int
a, Int
b, Int
c, Int
d, Int
e, Int
f, Int
g, Int
h, Int
i, Int
j, Int
k, Int
l, Int
m, Int
n, Int
o, Int
p, Int
q, Int
r, Int
s, Int
t, Int
u, Int
v, Int
w], Int
_) -> CtxOffsets -> ExceptT [[Char]] IO CtxOffsets
forall a. a -> ExceptT [[Char]] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> CtxOffsets
CtxOffsets Int
a Int
b Int
c Int
d Int
e Int
f Int
g Int
h Int
i Int
j Int
k Int
l Int
m Int
n Int
o Int
p Int
q Int
r Int
s Int
t Int
u Int
v Int
w)
      ([Int], Int)
_ -> [[Char]] -> ExceptT [[Char]] IO CtxOffsets
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE [[Char]
"unexpected Ctx layout; the JIT is off"]
  IO () -> ExceptT [[Char]] IO ()
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> Int -> Int -> Int -> Bool -> IO ()
configureNative (Config -> Int
stressPoll Config
config) (Config -> Int
stressCallee Config
config) (Config -> Int
stressCStack Config
config) (Config -> Int
stressAlloc Config
config) (Config -> Bool
trace Config
config))
  RtsFacts
rts <-
    IO [Int] -> ExceptT [[Char]] IO [Int]
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Int]
rtsFacts ExceptT [[Char]] IO [Int]
-> ([Int] -> ExceptT [[Char]] IO RtsFacts)
-> ExceptT [[Char]] IO RtsFacts
forall a b.
ExceptT [[Char]] IO a
-> (a -> ExceptT [[Char]] IO b) -> ExceptT [[Char]] IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- the allocator's address isn't needed: generated code calls
      -- unison_jit_alloc_words by name, and the JIT resolves it from the process
      [Int
arrWordsInfo, Int
arrPtrsInfo, Int
bytesHdr, Int
bytesCount, Int
ptrsHdr, Int
ptrsCount, Int
ptrsSize, Int
cardBits, Int
_allocator, Int
mutVarVar, Int
_barrier, Int
arrPtrsDirtyInfo] ->
        RtsFacts -> ExceptT [[Char]] IO RtsFacts
forall a. a -> ExceptT [[Char]] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> RtsFacts
RtsFacts Int
arrWordsInfo Int
arrPtrsInfo Int
bytesHdr Int
bytesCount Int
ptrsHdr Int
ptrsCount Int
ptrsSize Int
cardBits Int
mutVarVar Int
arrPtrsDirtyInfo)
      [Int]
_ -> [[Char]] -> ExceptT [[Char]] IO RtsFacts
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE [[Char]
"unexpected runtime facts; the JIT is off"]
  -- The C helpers' addresses go in first, as absolute symbols, so that
  -- nothing is looked up in the process's own symbol table (Linux doesn't
  -- expose an executable's symbols to dlsym without -rdynamic, Windows not
  -- at all). The names the IR modules define themselves are left to them:
  -- the exit routine (cbits/jit_exit.ll), which goes in whatever the
  -- switches say since every exit calls it, and the helpers written as IR
  -- (cbits/jit_helpers.ll), whose definitions shadow the C copies for
  -- generated code; with irhelpers disabled the C copies are defined
  -- instead.
  -- (On Windows the C copies can't stand in for the IR helpers: they
  -- return their (ok, value) pair through a hidden pointer under the Win64
  -- convention, where generated code expects the pair in registers, so the
  -- irhelpers switch is ignored.)
  let irDefines :: Text -> [[Char]]
irDefines Text
ir = [Text -> [Char]
T.unpack ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(') (Int -> Text -> Text
T.drop Int
1 ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@') Text
rest))) | Text
l <- Text -> [Text]
T.lines Text
ir, Just Text
rest <- [Text -> Text -> Maybe Text
T.stripPrefix Text
"define " Text
l]]
      noIRHelpers :: Bool
noIRHelpers = [Char]
"irhelpers" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [[Char]]
disabled Config
config Bool -> Bool -> Bool
&& [Char]
os [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"mingw32"
      irDefined :: [[Char]]
irDefined = Text -> [[Char]]
irDefines Text
exitIR [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if Bool
noIRHelpers then [] else Text -> [[Char]]
irDefines Text
helpersIR)
  Bool -> ExceptT [[Char]] IO () -> ExceptT [[Char]] IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
"irhelpers" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [[Char]]
disabled Config
config Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
noIRHelpers) (ExceptT [[Char]] IO () -> ExceptT [[Char]] IO ())
-> ExceptT [[Char]] IO () -> ExceptT [[Char]] IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> ExceptT [[Char]] IO ()
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Config -> [Char] -> IO ()
jitLog Config
config [Char]
"UNISON_JIT_DISABLE=irhelpers is ignored on Windows: the C copies return the (ok, value) pair differently from generated code there")
  [([Char], Word64)]
cHelpers <- IO [([Char], Word64)] -> ExceptT [[Char]] IO [([Char], Word64)]
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [([Char], Word64)]
helperAddresses
  ([Char] -> [[Char]])
-> ExceptT [Char] IO () -> ExceptT [[Char]] IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\[Char]
e -> [[Char]
"the C helpers could not be defined: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; the JIT is off"]) (ExceptT [Char] IO () -> ExceptT [[Char]] IO ())
-> ExceptT [Char] IO () -> ExceptT [[Char]] IO ()
forall a b. (a -> b) -> a -> b
$
    [([Char], Word64)]
-> (([Char], Word64) -> ExceptT [Char] IO ())
-> ExceptT [Char] IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([Char], Word64)
h | h :: ([Char], Word64)
h@([Char]
n, Word64
_) <- [([Char], Word64)]
cHelpers, [Char]
n [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
irDefined] (IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [Char] ()) -> ExceptT [Char] IO ())
-> (([Char], Word64) -> IO (Either [Char] ()))
-> ([Char], Word64)
-> ExceptT [Char] IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Word64 -> IO (Either [Char] ()))
-> ([Char], Word64) -> IO (Either [Char] ())
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> Word64 -> IO (Either [Char] ())
defineSymbol)
  ([Char] -> [[Char]])
-> ExceptT [Char] IO () -> ExceptT [[Char]] IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\[Char]
e -> [[Char]
"the exit routine (cbits/jit_exit.ll) " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; the JIT is off"]) (ExceptT [Char] IO () -> ExceptT [[Char]] IO ())
-> ExceptT [Char] IO () -> ExceptT [[Char]] IO ()
forall a b. (a -> b) -> a -> b
$ do
    ([Char] -> [Char]) -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ([Char]
"could not be added: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) (ExceptT [Char] IO (Maybe [Char]) -> ExceptT [Char] IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([Char]
-> ExceptT [Char] IO (Maybe [Char])
-> ExceptT [Char] IO (Maybe [Char])
forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
"exit routine" (IO (Either [Char] (Maybe [Char]))
-> ExceptT [Char] IO (Maybe [Char])
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Bool -> [Char] -> Text -> IO (Either [Char] (Maybe [Char]))
addModule Bool
False (Config -> [Char]
passes Config
config) Text
exitIR))))
    ([Char] -> [Char]) -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ([Char]
"not found after adding: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) (ExceptT [Char] IO (FunPtr ()) -> ExceptT [Char] IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either [Char] (FunPtr ())) -> ExceptT [Char] IO (FunPtr ())
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ([Char] -> IO (Either [Char] (FunPtr ()))
forall a. [Char] -> IO (Either [Char] (FunPtr a))
lookupSymbol [Char]
"unison_jit_exit_frame") :: ExceptT String IO (FunPtr ())))
  Bool -> ExceptT [[Char]] IO () -> ExceptT [[Char]] IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
noIRHelpers (ExceptT [[Char]] IO () -> ExceptT [[Char]] IO ())
-> ExceptT [[Char]] IO () -> ExceptT [[Char]] IO ()
forall a b. (a -> b) -> a -> b
$
    ([Char] -> [[Char]])
-> ExceptT [Char] IO () -> ExceptT [[Char]] IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\[Char]
e -> [[Char]
"the IR helpers (cbits/jit_helpers.ll) " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; the JIT is off"]) (ExceptT [Char] IO () -> ExceptT [[Char]] IO ())
-> ExceptT [Char] IO () -> ExceptT [[Char]] IO ()
forall a b. (a -> b) -> a -> b
$ do
      ([Char] -> [Char]) -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ([Char]
"could not be added: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
"IR helpers" (IO (Either [Char] ()) -> ExceptT [Char] IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Config -> IO (Either [Char] ())
addHelpers Config
config)))
      -- the module's definition must be the one generated code gets, not
      -- the C copy the process also has
      (FunPtr (ZonkAny 2)
p, FunPtr (ZonkAny 3)
q) <- ([Char] -> [Char])
-> ExceptT [Char] IO (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3))
-> ExceptT [Char] IO (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3))
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ([Char]
"not found after adding: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char]
-> ExceptT [Char] IO (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3))
-> ExceptT [Char] IO (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3))
forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
"IR helpers compiled" ((,) (FunPtr (ZonkAny 2)
 -> FunPtr (ZonkAny 3) -> (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3)))
-> ExceptT [Char] IO (FunPtr (ZonkAny 2))
-> ExceptT
     [Char]
     IO
     (FunPtr (ZonkAny 3) -> (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either [Char] (FunPtr (ZonkAny 2)))
-> ExceptT [Char] IO (FunPtr (ZonkAny 2))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ([Char] -> IO (Either [Char] (FunPtr (ZonkAny 2)))
forall a. [Char] -> IO (Either [Char] (FunPtr a))
lookupSymbol [Char]
"unison_jit_murmur") ExceptT
  [Char]
  IO
  (FunPtr (ZonkAny 3) -> (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3)))
-> ExceptT [Char] IO (FunPtr (ZonkAny 3))
-> ExceptT [Char] IO (FunPtr (ZonkAny 2), FunPtr (ZonkAny 3))
forall a b.
ExceptT [Char] IO (a -> b)
-> ExceptT [Char] IO a -> ExceptT [Char] IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Either [Char] (FunPtr (ZonkAny 3)))
-> ExceptT [Char] IO (FunPtr (ZonkAny 3))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ([Char] -> IO (Either [Char] (FunPtr (ZonkAny 3)))
forall a. [Char] -> IO (Either [Char] (FunPtr a))
lookupSymbol [Char]
"unison_jit_ucmp")))
      Bool -> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunPtr (ZonkAny 2) -> Ptr (ZonkAny 0)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (ZonkAny 2)
p Ptr (ZonkAny 0) -> Ptr (ZonkAny 0) -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr (Int64 -> Ptr () -> IO ()) -> Ptr (ZonkAny 0)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Int64 -> Ptr () -> IO ())
murmurCAddress Bool -> Bool -> Bool
|| FunPtr (ZonkAny 3) -> Ptr (ZonkAny 1)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (ZonkAny 3)
q Ptr (ZonkAny 1) -> Ptr (ZonkAny 1) -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr (Int64 -> Ptr () -> Int64 -> Ptr () -> Int64 -> IO ())
-> Ptr (ZonkAny 1)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Int64 -> Ptr () -> Int64 -> Ptr () -> Int64 -> IO ())
ucmpCAddress) (ExceptT [Char] IO () -> ExceptT [Char] IO ())
-> ExceptT [Char] IO () -> ExceptT [Char] IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> ExceptT [Char] IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE [Char]
"did not shadow the C copies"
  IO () -> ExceptT [[Char]] IO ()
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe JITState) -> Maybe JITState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (JIT -> IORef (Maybe JITState)
jitState JIT
jit) (JITState -> Maybe JITState
forall a. a -> Maybe a
Just (Layouts -> CtxOffsets -> RtsFacts -> JITState
JITState Layouts
ls CtxOffsets
ctx RtsFacts
rts)))
  [Char]
triple <- IO [Char] -> ExceptT [[Char]] IO [Char]
forall a. IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
targetTriple
  pure ([Char]
"mode " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Mode -> [Char]
forall a. Show a => a -> [Char]
show (Config -> Mode
mode Config
config) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", LLVM " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
version [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", target " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
triple)
  where
    config :: Config
config = JIT -> Config
jitConfig JIT
jit
    off :: ExceptT [Char] IO a -> ExceptT [[Char]] IO a
off = ([Char] -> [[Char]])
-> ExceptT [Char] IO a -> ExceptT [[Char]] IO a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (\[Char]
e -> [[Char]
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; the JIT is off"])
    timed :: String -> ExceptT e IO a -> ExceptT e IO a
    timed :: forall e a. [Char] -> ExceptT e IO a -> ExceptT e IO a
timed [Char]
what ExceptT e IO a
act = do
      Word64
t0 <- IO Word64 -> ExceptT e IO Word64
forall a. IO a -> ExceptT e IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
      a
x <- ExceptT e IO a
act
      Word64
t1 <- IO Word64 -> ExceptT e IO Word64
forall a. IO a -> ExceptT e IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
      a
x a -> ExceptT e IO () -> ExceptT e IO a
forall a b. a -> ExceptT e IO b -> ExceptT e IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> ExceptT e IO ()
forall a. IO a -> ExceptT e IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Config -> [Char] -> IO ()
jitLog Config
config ([Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ms"))

-- | Adds the IR helpers' module, after defining the names of the runtime's
-- tables it refers to ("The IR helpers" in design.md).
addHelpers :: Config -> IO (Either String ())
addHelpers :: Config -> IO (Either [Char] ())
addHelpers Config
config = do
  [([Char], Word64)]
tables <- IO [([Char], Word64)]
tableAddresses
  Either [Char] ()
defined <- [Either [Char] ()] -> Either [Char] ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Either [Char] ()] -> Either [Char] ())
-> IO [Either [Char] ()] -> IO (Either [Char] ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Char], Word64) -> IO (Either [Char] ()))
-> [([Char], Word64)] -> IO [Either [Char] ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (([Char] -> Word64 -> IO (Either [Char] ()))
-> ([Char], Word64) -> IO (Either [Char] ())
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> Word64 -> IO (Either [Char] ())
defineSymbol) [([Char], Word64)]
tables
  case Either [Char] ()
defined of
    Left [Char]
e -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e)
    Right () -> Either [Char] (Maybe [Char]) -> Either [Char] ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either [Char] (Maybe [Char]) -> Either [Char] ())
-> IO (Either [Char] (Maybe [Char])) -> IO (Either [Char] ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Char] -> Text -> IO (Either [Char] (Maybe [Char]))
addModule Bool
False (Config -> [Char]
passes Config
config) Text
helpersIR

-- | The oldest LLVM the shim works with (why: cbits/jit_llvm.c).
minLLVM :: Int
minLLVM :: Int
minLLVM = Int
20

-- | Compiles a freshly loaded top-level definition, in eager mode.
jitCompileGroup :: JIT -> Bool -> Reference -> Word64 -> MCombs -> IO ()
jitCompileGroup :: JIT -> Bool -> Reference -> Word64 -> MCombs -> IO ()
jitCompileGroup JIT
jit Bool
sandbox Reference
ref Word64
grp MCombs
cmbs = case Config -> Mode
mode (JIT -> Config
jitConfig JIT
jit) of
  Mode
Eager ->
    IORef (Maybe JITState) -> IO (Maybe JITState)
forall a. IORef a -> IO a
readIORef (JIT -> IORef (Maybe JITState)
jitState JIT
jit) IO (Maybe JITState) -> (Maybe JITState -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe JITState
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just JITState
st -> do
        EnumMap Word64 Reference
numbers <- IORef (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. IORef a -> IO a
readIORef (JIT -> IORef (EnumMap Word64 Reference)
jitTypeNumbers JIT
jit)
        ([Unit]
now, [Unit]
_) <- Compiler
-> Bool
-> Bool
-> Reference
-> Word64
-> MCombs
-> IO ([Unit], [Unit])
groupUnits (JIT -> Compiler
jitCompiler JIT
jit) Bool
sandbox Bool
False Reference
ref Word64
grp MCombs
cmbs
        Config -> [Char] -> IO () -> IO ()
guarded (JIT -> Config
jitConfig JIT
jit) ([Char]
"unison_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp) (Compiler
-> JITState
-> EnumMap Word64 Reference
-> [Char]
-> Bool
-> [Unit]
-> IO ()
compileUnits (JIT -> Compiler
jitCompiler JIT
jit) JITState
st EnumMap Word64 Reference
numbers ([Char]
"unison_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp) Bool
False [Unit]
now)
  Mode
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- ---------------------------------------------------------------------------
-- The @on@ mode: compiling what gets hot, on a thread of its own.
-- See design.md, "What gets compiled, and when".

-- | What the interpreter asks the compile thread for.
data Request
  = -- | compile this definition: its group number, and how to read the
    -- code cache (every group's combinators, and their references)
    ReqGroup !Word64 !Bool !Word64 (IO (EC.EnumMap Word64 MCombs, EC.EnumMap Word64 Reference))
  | -- | generate a re-entry function that was left for later
    ReqUnit Unit

-- | Queues a request if there is room; says whether there was.
offer :: JIT -> Request -> IO Bool
offer :: JIT -> Request -> IO Bool
offer JIT
jit Request
r = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
  Bool
full <- TBQueue Request -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue (JIT -> TBQueue Request
jitRequests JIT
jit)
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
full (TBQueue Request -> Request -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (JIT -> TBQueue Request
jitRequests JIT
jit) Request
r)
  pure (Bool -> Bool
not Bool
full)

-- | The cell of a definition's entry combinator. Its state stands for the
-- whole definition: requested from the moment a request for the
-- definition is queued, taken once the compile thread has it in a batch.
-- It never goes back, so a definition is queued at most once.
entryCell :: MCombs -> Maybe (Ptr NativeCell)
entryCell :: MCombs -> Maybe (Ptr NativeCell)
entryCell MCombs
cmbs = case Word64 -> MCombs -> Maybe (GComb Val (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
0 MCombs
cmbs of
  Just (Comb (LamI Int
_ Int
_ GSection (RComb Val)
_ Ptr NativeCell
cell)) | Ptr NativeCell
cell Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr NativeCell
noNativeCell -> Ptr NativeCell -> Maybe (Ptr NativeCell)
forall a. a -> Maybe a
Just Ptr NativeCell
cell
  Maybe (GComb Val (RComb Val))
_ -> Maybe (Ptr NativeCell)
forall a. Maybe a
Nothing

-- | Asks for the definition this combinator belongs to to be compiled.
-- Called by the interpreter when the combinator's call count says it is
-- hot (see 'bumpNativeCount'). If the queue is full the flag is cleared
-- again and the count set to ask again after another 1024 calls.
-- The cache's combinators and their references are given as the TVars,
-- read again on the compile thread when the request is served.
jitRequestGroup :: JIT -> Bool -> TVar (EC.EnumMap Word64 MCombs) -> TVar (EC.EnumMap Word64 Reference) -> CombIx -> Ptr NativeCell -> IO ()
jitRequestGroup :: JIT
-> Bool
-> TVar (EnumMap Word64 MCombs)
-> TVar (EnumMap Word64 Reference)
-> CombIx
-> Ptr NativeCell
-> IO ()
jitRequestGroup JIT
jit Bool
sandboxed TVar (EnumMap Word64 MCombs)
combs TVar (EnumMap Word64 Reference)
combRefs (CIx Reference
_ Word64
grp Word64
_) Ptr NativeCell
cell
  | Ptr NativeCell
cell Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr NativeCell
noNativeCell = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- a builtin, or code not loaded through the cache
  | Bool
otherwise = do
      EnumMap Word64 MCombs
cache <- TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a. TVar a -> IO a
readTVarIO TVar (EnumMap Word64 MCombs)
combs
      Maybe (Ptr NativeCell) -> (Ptr NativeCell -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
grp EnumMap Word64 MCombs
cache Maybe MCombs
-> (MCombs -> Maybe (Ptr NativeCell)) -> Maybe (Ptr NativeCell)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MCombs -> Maybe (Ptr NativeCell)
entryCell) ((Ptr NativeCell -> IO ()) -> IO ())
-> (Ptr NativeCell -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr NativeCell
entry -> do
        Bool
mine <- Ptr NativeCell -> IO Bool
claimNativeCell Ptr NativeCell
entry
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mine (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Word64
t0 <- IO Word64
getMonotonicTimeNSec
          Bool
queued <- JIT -> Request -> IO Bool
offer JIT
jit (Word64
-> Bool
-> Word64
-> IO (EnumMap Word64 MCombs, EnumMap Word64 Reference)
-> Request
ReqGroup Word64
grp Bool
sandboxed Word64
t0 ((,) (EnumMap Word64 MCombs
 -> EnumMap Word64 Reference
 -> (EnumMap Word64 MCombs, EnumMap Word64 Reference))
-> IO (EnumMap Word64 MCombs)
-> IO
     (EnumMap Word64 Reference
      -> (EnumMap Word64 MCombs, EnumMap Word64 Reference))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (EnumMap Word64 MCombs) -> IO (EnumMap Word64 MCombs)
forall a. TVar a -> IO a
readTVarIO TVar (EnumMap Word64 MCombs)
combs IO
  (EnumMap Word64 Reference
   -> (EnumMap Word64 MCombs, EnumMap Word64 Reference))
-> IO (EnumMap Word64 Reference)
-> IO (EnumMap Word64 MCombs, EnumMap Word64 Reference)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. TVar a -> IO a
readTVarIO TVar (EnumMap Word64 Reference)
combRefs))
          if Bool
queued
            then
              -- Entering the scheduler is what hands a runnable thread to an
              -- idle capability: without this the compile thread, if it is
              -- on this capability, starts at this capability's next GC or
              -- context-switch tick, a thousand interpreted calls later on
              -- an optimized build (UNISON_JIT_LOG reports the lag).
              IO ()
yield
            else do
              Ptr NativeCell -> IO ()
releaseNativeCell Ptr NativeCell
entry
              Ptr NativeCell -> Int -> IO ()
writeNativeCount Ptr NativeCell
cell (-Int
1024)
{-# NOINLINE jitRequestGroup #-}

-- | Asks for the re-entry function that belongs in this cell to be
-- generated, if there is one waiting (see 'Compile.pending'). Called by
-- the interpreter when it has found the cell empty often enough. The
-- cell's request state keeps it from being queued twice.
jitRequestCell :: JIT -> Ptr NativeCell -> IO ()
jitRequestCell :: JIT -> Ptr NativeCell -> IO ()
jitRequestCell JIT
jit Ptr NativeCell
cell =
  Compiler -> Ptr NativeCell -> IO (Maybe Unit)
lookupPending (JIT -> Compiler
jitCompiler JIT
jit) Ptr NativeCell
cell IO (Maybe Unit) -> (Maybe Unit -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Unit
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Unit
u -> do
      Bool
mine <- Ptr NativeCell -> IO Bool
claimNativeCell Ptr NativeCell
cell
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mine (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
queued <- JIT -> Request -> IO Bool
offer JIT
jit (Unit -> Request
ReqUnit Unit
u)
        -- addPending starts the count again
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
queued (Ptr NativeCell -> IO ()
releaseNativeCell Ptr NativeCell
cell IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Compiler -> Unit -> IO ()
addPending (JIT -> Compiler
jitCompiler JIT
jit) Unit
u)
{-# NOINLINE jitRequestCell #-}

-- | The trampoline's report of an ad hoc exit (the poll, the allocation
-- budget, stack growth: 'isAdHoc') that unwound through a Let whose body
-- has no code yet. The exits the code itself causes count toward the
-- body's re-entry function when its frame is popped (Machine.countReentry)
-- and are bounded by the code; these land wherever the program is, so
-- a long-running function would in time be interrupted at every Let it
-- has and get a copy of its suffix after each. So they count here, and
-- only while the group's budget lasts ('reentryAdHoc', 3): the Lets most
-- often on the stack at a tick, where the time goes, are the ones that
-- get in. The frame the trampoline builds for such an exit carries no
-- cell, so the pop interprets the body without counting it again.
noteAdHocExit :: JIT -> Word64 -> Ptr NativeCell -> IO ()
noteAdHocExit :: JIT -> Word64 -> Ptr NativeCell -> IO ()
noteAdHocExit JIT
jit Word64
grp Ptr NativeCell
cell =
  Compiler -> Ptr NativeCell -> IO (Maybe Unit)
lookupPending (JIT -> Compiler
jitCompiler JIT
jit) Ptr NativeCell
cell IO (Maybe Unit) -> (Maybe Unit -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Unit
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Unit
_ -> do
      let allowance :: Int
allowance = Config -> Int
reentryAdHoc (JIT -> Config
jitConfig JIT
jit)
          left :: AdHoc -> Int
left AdHoc
a = Int -> Word64 -> EnumMap Word64 Int -> Int
forall k a. EnumKey k => a -> k -> EnumMap k a -> a
EC.lookupWithDefault Int
allowance Word64
grp (AdHoc -> EnumMap Word64 Int
ahBudgets AdHoc
a)
      Bool
allowed <- IORef AdHoc -> (AdHoc -> (AdHoc, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (JIT -> IORef AdHoc
jitAdHoc JIT
jit) ((AdHoc -> (AdHoc, Bool)) -> IO Bool)
-> (AdHoc -> (AdHoc, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \AdHoc
a ->
        if AdHoc -> Int
left AdHoc
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then (AdHoc
a, Bool
True) else (AdHoc
a {ahRefused = ahRefused a + 1}, Bool
False)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
allowed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
hot <- Ptr NativeCell -> IO Bool
bumpNativeCount Ptr NativeCell
cell
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hot (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          IORef AdHoc -> (AdHoc -> (AdHoc, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (JIT -> IORef AdHoc
jitAdHoc JIT
jit) ((AdHoc -> (AdHoc, ())) -> IO ())
-> (AdHoc -> (AdHoc, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AdHoc
a ->
            (AdHoc
a {ahBudgets = EC.mapInsert grp (left a - 1) (ahBudgets a), ahRequested = ahRequested a + 1}, ())
          JIT -> Ptr NativeCell -> IO ()
jitRequestCell JIT
jit Ptr NativeCell
cell

-- | Which definitions call which: for each group, the groups whose code
-- refers to it. The code cache only records the other direction, so the
-- compile thread keeps this, adding the groups loaded since it last looked.
data Callers = Callers !(Set.Set Word64) !(Map.Map Word64 (Set.Set Word64))

indexCallers :: EC.EnumMap Word64 MCombs -> Callers -> Callers
indexCallers :: EnumMap Word64 MCombs -> Callers -> Callers
indexCallers EnumMap Word64 MCombs
cache (Callers Set Word64
seen Map Word64 (Set Word64)
callers) =
  Set Word64 -> Map Word64 (Set Word64) -> Callers
Callers
    (Set Word64 -> Set Word64 -> Set Word64
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Word64
seen ([Word64] -> Set Word64
forall a. Ord a => [a] -> Set a
Set.fromList (((Word64, MCombs) -> Word64) -> [(Word64, MCombs)] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (Word64, MCombs) -> Word64
forall a b. (a, b) -> a
fst [(Word64, MCombs)]
new)))
    ((Set Word64 -> Set Word64 -> Set Word64)
-> Map Word64 (Set Word64)
-> Map Word64 (Set Word64)
-> Map Word64 (Set Word64)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set Word64 -> Set Word64 -> Set Word64
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map Word64 (Set Word64)
callers ((Set Word64 -> Set Word64 -> Set Word64)
-> [(Word64, Set Word64)] -> Map Word64 (Set Word64)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Word64 -> Set Word64 -> Set Word64
forall a. Ord a => Set a -> Set a -> Set a
Set.union [(Word64
d, Word64 -> Set Word64
forall a. a -> Set a
Set.singleton Word64
g) | (Word64
g, MCombs
cmbs) <- [(Word64, MCombs)]
new, Word64
d <- Word64 -> MCombs -> [Word64]
groupDeps Word64
g MCombs
cmbs]))
  where
    new :: [(Word64, MCombs)]
new = [(Word64, MCombs)
gc | gc :: (Word64, MCombs)
gc@(Word64
g, MCombs
_) <- EnumMap Word64 MCombs -> [(Word64, MCombs)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 MCombs
cache, Bool -> Bool
not (Word64 -> Set Word64 -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Word64
g Set Word64
seen)]

-- | The other groups a group's code refers to.
groupDeps :: Word64 -> MCombs -> [Word64]
groupDeps :: Word64 -> MCombs -> [Word64]
groupDeps Word64
g MCombs
cmbs = Set Word64 -> [Word64]
forall a. Set a -> [a]
Set.toList (Word64 -> Set Word64 -> Set Word64
forall a. Ord a => a -> Set a -> Set a
Set.delete Word64
g ([Word64] -> Set Word64
forall a. Ord a => [a] -> Set a
Set.fromList [Word64
d | (Word64
_, GComb Val (RComb Val)
c) <- MCombs -> [(Word64, GComb Val (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList MCombs
cmbs, Word64
d <- GComb Val (RComb Val) -> [Word64]
forall val comb. GComb val comb -> [Word64]
combDeps GComb Val (RComb Val)
c]))

-- | Which side of an edge a batch member is on.
data Role = Callee | Caller

-- | The estimated calls from a group's code to group @d@: for each of its
-- combinators, the combinator's own call count times the static call
-- sites of @d@ in it.
edgeCalls :: Config -> MCombs -> Word64 -> IO Double
edgeCalls :: Config -> MCombs -> Word64 -> IO Double
edgeCalls Config
config MCombs
cmbs Word64
d = ([Double] -> Double) -> IO [Double] -> IO Double
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (IO [Double] -> IO Double)
-> (((Word64, GComb Val (RComb Val)) -> IO Double) -> IO [Double])
-> ((Word64, GComb Val (RComb Val)) -> IO Double)
-> IO Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word64, GComb Val (RComb Val))]
-> ((Word64, GComb Val (RComb Val)) -> IO Double) -> IO [Double]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (MCombs -> [(Word64, GComb Val (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList MCombs
cmbs) (((Word64, GComb Val (RComb Val)) -> IO Double) -> IO Double)
-> ((Word64, GComb Val (RComb Val)) -> IO Double) -> IO Double
forall a b. (a -> b) -> a -> b
$ \(Word64
_, GComb Val (RComb Val)
c) -> case GComb Val (RComb Val)
c of
  Comb (LamI Int
_ Int
_ GSection (RComb Val)
_ Ptr NativeCell
cell)
    | Ptr NativeCell
cell Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr NativeCell
noNativeCell,
      Int
sites <- [Word64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Word64 -> Bool) -> [Word64] -> [Word64]
forall a. (a -> Bool) -> [a] -> [a]
filter (Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
d) (GComb Val (RComb Val) -> [Word64]
forall val comb. GComb val comb -> [Word64]
combDeps GComb Val (RComb Val)
c)),
      Int
sites Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
        -- counts start at minus the threshold
        Int
n <- Ptr NativeCell -> IO Int
readNativeCount Ptr NativeCell
cell
        pure (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Config -> Int
threshold Config
config)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sites)
  GComb Val (RComb Val)
_ -> Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0

-- | A group's size, as a proxy for the code generated for it: for each
-- combinator, its frame size times its call sites. On the suite the IR
-- grows with both (the slots live across a call are written to the stack
-- around it): the suite's own body, 183 lines of MCode with a frame of 128
-- slots and 56 sites, was 55k lines of IR, and a typical hot function
-- under 500 (2026-10-09).
groupSize :: MCombs -> Int
groupSize :: MCombs -> Int
groupSize MCombs
cmbs = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Word64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (GComb Val (RComb Val) -> [Word64]
forall val comb. GComb val comb -> [Word64]
combDeps GComb Val (RComb Val)
c) | (Word64
_, c :: GComb Val (RComb Val)
c@(Comb (LamI Int
_ Int
f GSection (RComb Val)
_ Ptr NativeCell
_))) <- MCombs -> [(Word64, GComb Val (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList MCombs
cmbs]

-- | Serves requests, forever. LLVM is only ever used from this thread (in
-- @on@ mode); it is normally loaded at startup already, and if not, by the
-- first request.
--
-- A definition that got hot is compiled as soon as its request comes up.
-- Requests for re-entry functions are held instead, and compiled together
-- as one module once there are a batch of them or no request has come for
-- 'reentryWait' milliseconds: each would otherwise be a module of its own,
-- paying LLVM's per-module cost for a few dozen instructions, and nothing
-- is lost by the wait, since a re-entry point that doesn't exist yet is
-- resumed by the interpreter as it was before the counter said to generate
-- it. A definition's request is served ahead of the held re-entry
-- functions, so the wait never delays a hot loop.
compileThread :: JIT -> IO ()
compileThread :: JIT -> IO ()
compileThread JIT
jit = do
  IORef Bool
initialized <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  IORef Callers
callersRef <- Callers -> IO (IORef Callers)
forall a. a -> IO (IORef a)
newIORef (Set Word64 -> Map Word64 (Set Word64) -> Callers
Callers Set Word64
forall a. Set a
Set.empty Map Word64 (Set Word64)
forall k a. Map k a
Map.empty)
  let loop :: [Unit] -> IO ()
loop [Unit]
held = do
        Maybe Request
next <-
          if [Unit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Unit]
held
            then Request -> Maybe Request
forall a. a -> Maybe a
Just (Request -> Maybe Request) -> IO Request -> IO (Maybe Request)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Request -> IO Request
forall a. STM a -> IO a
atomically (TBQueue Request -> STM Request
forall a. TBQueue a -> STM a
readTBQueue (JIT -> TBQueue Request
jitRequests JIT
jit))
            else Int -> IO Request -> IO (Maybe Request)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Config -> Int
reentryWait Config
config Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (STM Request -> IO Request
forall a. STM a -> IO a
atomically (TBQueue Request -> STM Request
forall a. TBQueue a -> STM a
readTBQueue (JIT -> TBQueue Request
jitRequests JIT
jit)))
        case Maybe Request
next of
          Maybe Request
Nothing -> [Unit] -> IO ()
flush [Unit]
held IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Unit] -> IO ()
loop []
          Just (ReqUnit Unit
u) | Config -> Int
reentryWait Config
config Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
            let held' :: [Unit]
held' = Unit
u Unit -> [Unit] -> [Unit]
forall a. a -> [a] -> [a]
: [Unit]
held
            if [Unit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Unit]
held' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Config -> Int
batch Config
config then [Unit] -> IO ()
flush [Unit]
held' IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Unit] -> IO ()
loop [] else [Unit] -> IO ()
loop [Unit]
held'
          Just Request
req -> do
            Either SomeException ()
r <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IORef Bool -> IORef Callers -> Request -> IO ()
serve IORef Bool
initialized IORef Callers
callersRef Request
req)
            case Either SomeException ()
r of
              Left (SomeException
e :: SomeException) -> Config -> [Char] -> IO ()
jitLog Config
config ([Char]
"compile thread: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e)
              Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            [Unit] -> IO ()
loop [Unit]
held
      flush :: [Unit] -> IO ()
flush [] = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      flush [Unit]
held = do
        Either SomeException ()
r <-
          IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try
            ( IORef Bool
-> (JITState -> EnumMap Word64 Reference -> IO ()) -> IO ()
withState IORef Bool
initialized ((JITState -> EnumMap Word64 Reference -> IO ()) -> IO ())
-> (JITState -> EnumMap Word64 Reference -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \JITState
st EnumMap Word64 Reference
numbers -> do
                let name :: [Char]
name = [Char]
"unison_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Unit -> [Char]
unitName ([Unit] -> Unit
forall a. HasCallStack => [a] -> a
last [Unit]
held) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_x" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Unit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Unit]
held)
                Config -> [Char] -> IO () -> IO ()
guarded Config
config [Char]
name (Compiler
-> JITState
-> EnumMap Word64 Reference
-> [Char]
-> Bool
-> [Unit]
-> IO ()
compileUnits Compiler
c JITState
st EnumMap Word64 Reference
numbers [Char]
name Bool
True ([Unit] -> [Unit]
forall a. [a] -> [a]
reverse [Unit]
held))
                [Unit] -> (Unit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Unit]
held (Compiler -> Unit -> IO ()
dropPending Compiler
c)
            )
        case Either SomeException ()
r of
          Left (SomeException
e :: SomeException) -> Config -> [Char] -> IO ()
jitLog Config
config ([Char]
"compile thread: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e)
          Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  [Unit] -> IO ()
loop []
  where
    config :: Config
config = JIT -> Config
jitConfig JIT
jit
    c :: Compiler
c = JIT -> Compiler
jitCompiler JIT
jit
    withState :: IORef Bool
-> (JITState -> EnumMap Word64 Reference -> IO ()) -> IO ()
withState IORef Bool
initialized JITState -> EnumMap Word64 Reference -> IO ()
k = do
      Bool
ready <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
initialized
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ready (IO (Either [[Char]] [Char]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JIT -> IO (Either [[Char]] [Char])
initJIT JIT
jit) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
initialized Bool
True)
      IORef (Maybe JITState) -> IO (Maybe JITState)
forall a. IORef a -> IO a
readIORef (JIT -> IORef (Maybe JITState)
jitState JIT
jit) IO (Maybe JITState) -> (Maybe JITState -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe JITState
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just JITState
st -> do
          EnumMap Word64 Reference
numbers <- IORef (EnumMap Word64 Reference) -> IO (EnumMap Word64 Reference)
forall a. IORef a -> IO a
readIORef (JIT -> IORef (EnumMap Word64 Reference)
jitTypeNumbers JIT
jit)
          JITState -> EnumMap Word64 Reference -> IO ()
k JITState
st EnumMap Word64 Reference
numbers
    serve :: IORef Bool -> IORef Callers -> Request -> IO ()
serve IORef Bool
initialized IORef Callers
callersRef Request
req =
      IORef Bool
-> (JITState -> EnumMap Word64 Reference -> IO ()) -> IO ()
withState IORef Bool
initialized ((JITState -> EnumMap Word64 Reference -> IO ()) -> IO ())
-> (JITState -> EnumMap Word64 Reference -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \JITState
st EnumMap Word64 Reference
numbers -> do
        case Request
req of
          ReqGroup Word64
grp Bool
sandbox Word64
t0 IO (EnumMap Word64 MCombs, EnumMap Word64 Reference)
find -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
logging Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Word64
t1 <- IO Word64
getMonotonicTimeNSec
              Config -> [Char] -> IO ()
jitLog Config
config ([Char]
"request for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" served after " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show ((Word64
t1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t0) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1000) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" us")
            (EnumMap Word64 MCombs
cache, EnumMap Word64 Reference
refs) <- IO (EnumMap Word64 MCombs, EnumMap Word64 Reference)
find
            -- a request whose definition went into an earlier batch is dropped
            Bool
mine <- IO Bool
-> (Ptr NativeCell -> IO Bool) -> Maybe (Ptr NativeCell) -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) Ptr NativeCell -> IO Bool
takeNativeCell (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
grp EnumMap Word64 MCombs
cache Maybe MCombs
-> (MCombs -> Maybe (Ptr NativeCell)) -> Maybe (Ptr NativeCell)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MCombs -> Maybe (Ptr NativeCell)
entryCell)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mine (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              IORef Callers -> (Callers -> Callers) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Callers
callersRef (EnumMap Word64 MCombs -> Callers -> Callers
indexCallers EnumMap Word64 MCombs
cache)
              Callers Set Word64
_ Map Word64 (Set Word64)
callers <- IORef Callers -> IO Callers
forall a. IORef a -> IO a
readIORef IORef Callers
callersRef
              [Word64]
members <- EnumMap Word64 MCombs
-> Map Word64 (Set Word64) -> Word64 -> IO [Word64]
formBatch EnumMap Word64 MCombs
cache Map Word64 (Set Word64)
callers Word64
grp
              ([[Unit]]
now, [[Unit]]
later) <-
                [([Unit], [Unit])] -> ([[Unit]], [[Unit]])
forall a b. [(a, b)] -> ([a], [b])
unzip
                  ([([Unit], [Unit])] -> ([[Unit]], [[Unit]]))
-> IO [([Unit], [Unit])] -> IO ([[Unit]], [[Unit]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO ([Unit], [Unit])] -> IO [([Unit], [Unit])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
                    [ Compiler
-> Bool
-> Bool
-> Reference
-> Word64
-> MCombs
-> IO ([Unit], [Unit])
groupUnits Compiler
c Bool
sandbox Bool
True Reference
ref Word64
g MCombs
cmbs
                    | Word64
g <- [Word64]
members,
                      Just MCombs
cmbs <- [Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
g EnumMap Word64 MCombs
cache],
                      Just Reference
ref <- [Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
g EnumMap Word64 Reference
refs]
                    ]
              -- pending before the groups' code can exit to them
              [Unit] -> (Unit -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([[Unit]] -> [Unit]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Unit]]
later) (Compiler -> Unit -> IO ()
addPending Compiler
c)
              [Unit]
copies <- Bool
-> EnumMap Word64 MCombs
-> EnumMap Word64 Reference
-> [Word64]
-> IO [Unit]
copyCandidates Bool
sandbox EnumMap Word64 MCombs
cache EnumMap Word64 Reference
refs [Word64]
members
              Config -> [Char] -> IO () -> IO ()
guarded Config
config ([Char]
"unison_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp) (Compiler
-> JITState
-> EnumMap Word64 Reference
-> [Char]
-> Bool
-> [Unit]
-> IO ()
compileUnits Compiler
c JITState
st EnumMap Word64 Reference
numbers ([Char]
"unison_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp) Bool
True ([[Unit]] -> [Unit]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Unit]]
now [Unit] -> [Unit] -> [Unit]
forall a. [a] -> [a] -> [a]
++ [Unit]
copies))
          ReqUnit Unit
u -> do
            Config -> [Char] -> IO () -> IO ()
guarded Config
config (Unit -> [Char]
unitName Unit
u) (Compiler
-> JITState
-> EnumMap Word64 Reference
-> [Char]
-> Bool
-> [Unit]
-> IO ()
compileUnits Compiler
c JITState
st EnumMap Word64 Reference
numbers ([Char]
"unison_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Unit -> [Char]
unitName Unit
u) Bool
True [Unit
u])
            Compiler -> Unit -> IO ()
dropPending Compiler
c Unit
u
    -- The definitions to compile together with one that got hot, so that
    -- calls between them are direct and LLVM can inline across them. The
    -- batch grows from the hot definition one neighbour at a time (Prim's
    -- algorithm): the candidate with the most estimated calls across its
    -- edges to the batch so far joins next, once those calls reach the
    -- gate, up to the batch size. See design.md for more.
    formBatch :: EnumMap Word64 MCombs
-> Map Word64 (Set Word64) -> Word64 -> IO [Word64]
formBatch EnumMap Word64 MCombs
cache Map Word64 (Set Word64)
callers Word64
grp = do
      IORef Int
seq0 <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let full :: [Word64] -> Bool
full [Word64]
taken = [Word64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
taken Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Config -> Int
batch Config
config
          -- the neighbours of g, with the role g plays for each
          around :: Word64 -> [(Role, Word64)]
around Word64
g = (Word64 -> (Role, Word64)) -> [Word64] -> [(Role, Word64)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Role
Callee) ([Word64] -> (MCombs -> [Word64]) -> Maybe MCombs -> [Word64]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Word64 -> MCombs -> [Word64]
groupDeps Word64
g) (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
g EnumMap Word64 MCombs
cache)) [(Role, Word64)] -> [(Role, Word64)] -> [(Role, Word64)]
forall a. [a] -> [a] -> [a]
++ (Word64 -> (Role, Word64)) -> [Word64] -> [(Role, Word64)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Role
Caller) (Set Word64 -> [Word64]
forall a. Set a -> [a]
Set.toList (Set Word64 -> Word64 -> Map Word64 (Set Word64) -> Set Word64
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set Word64
forall a. Set a
Set.empty Word64
g Map Word64 (Set Word64)
callers))
          -- the estimated calls across the edge between g and v
          weight :: Role -> Word64 -> Word64 -> IO Double
weight Role
role Word64
g Word64
v = case Role
role of
            Role
Callee -> IO Double -> (MCombs -> IO Double) -> Maybe MCombs -> IO Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0) (\MCombs
cmbs -> Config -> MCombs -> Word64 -> IO Double
edgeCalls Config
config MCombs
cmbs Word64
v) (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
g EnumMap Word64 MCombs
cache)
            Role
Caller -> IO Double -> (MCombs -> IO Double) -> Maybe MCombs -> IO Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0) (\MCombs
cmbs -> Config -> MCombs -> Word64 -> IO Double
edgeCalls Config
config MCombs
cmbs Word64
g) (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
v EnumMap Word64 MCombs
cache)
          -- adds g's neighbours to the candidates, or more weight to ones already there
          expand :: Word64
-> (Set Word64, Map Word64 (Double, Int))
-> IO (Map Word64 (Double, Int))
expand Word64
g (Set Word64
seen, Map Word64 (Double, Int)
cands) = (Map Word64 (Double, Int)
 -> (Role, Word64) -> IO (Map Word64 (Double, Int)))
-> Map Word64 (Double, Int)
-> [(Role, Word64)]
-> IO (Map Word64 (Double, Int))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Word64 (Double, Int)
-> (Role, Word64) -> IO (Map Word64 (Double, Int))
add Map Word64 (Double, Int)
cands (Word64 -> [(Role, Word64)]
around Word64
g)
            where
              add :: Map Word64 (Double, Int)
-> (Role, Word64) -> IO (Map Word64 (Double, Int))
add Map Word64 (Double, Int)
cs (Role
role, Word64
v)
                | Word64 -> Set Word64 -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Word64
v Set Word64
seen = Map Word64 (Double, Int) -> IO (Map Word64 (Double, Int))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Word64 (Double, Int)
cs
                | Bool
otherwise = do
                    Double
w <- Role -> Word64 -> Word64 -> IO Double
weight Role
role Word64
g Word64
v
                    Int
n <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
seq0
                    IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
seq0 (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    pure (((Double, Int) -> (Double, Int) -> (Double, Int))
-> Word64
-> (Double, Int)
-> Map Word64 (Double, Int)
-> Map Word64 (Double, Int)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\(Double
w', Int
_) (Double
w0, Int
s0) -> (Double
w0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
w', Int
s0)) Word64
v (Double
w, Int
n) Map Word64 (Double, Int)
cs)
          -- whether a candidate may join now: hot on its own, or enough
          -- estimated calls for its size (a large candidate costs more to
          -- compile, so cutting an edge into it has to save more calls)
          passes :: Word64 -> (Double, Int) -> IO Bool
passes Word64
v (Double
w, Int
_) = case Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
v EnumMap Word64 MCombs
cache of
            Just MCombs
cmbs | Just Ptr NativeCell
cell <- MCombs -> Maybe (Ptr NativeCell)
entryCell MCombs
cmbs -> do
              Bool
hot <- Ptr NativeCell -> IO Bool
nativeCellRequested Ptr NativeCell
cell
              let scale :: Double
scale = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MCombs -> Int
groupSize MCombs
cmbs) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Config -> Int
sizeUnit Config
config))
              pure (Bool
hot Bool -> Bool -> Bool
|| Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
scale Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Config -> Int
batchGate Config
config))
            Maybe MCombs
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          -- the candidate with the most weight, then the earliest seen
          best :: Map a (Double, Int) -> Maybe (a, (Double, Int))
best =
            (Maybe (a, (Double, Int))
 -> a -> (Double, Int) -> Maybe (a, (Double, Int)))
-> Maybe (a, (Double, Int))
-> Map a (Double, Int)
-> Maybe (a, (Double, Int))
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey'
              ( \Maybe (a, (Double, Int))
acc a
v (Double
w, Int
n) -> case Maybe (a, (Double, Int))
acc of
                  Just (a
_, (Double
w', Int
n')) | (Double
w', Int -> Int
forall a. Num a => a -> a
negate Int
n') (Double, Int) -> (Double, Int) -> Bool
forall a. Ord a => a -> a -> Bool
>= (Double
w, Int -> Int
forall a. Num a => a -> a
negate Int
n) -> Maybe (a, (Double, Int))
acc
                  Maybe (a, (Double, Int))
_ -> (a, (Double, Int)) -> Maybe (a, (Double, Int))
forall a. a -> Maybe a
Just (a
v, (Double
w, Int
n))
              )
              Maybe (a, (Double, Int))
forall a. Maybe a
Nothing
          go :: [Word64]
-> Set Word64
-> Map Word64 (Double, Int)
-> IO ([Word64], Map Word64 (Double, Int))
go [Word64]
taken Set Word64
seen Map Word64 (Double, Int)
cands
            | [Word64] -> Bool
full [Word64]
taken = ([Word64], Map Word64 (Double, Int))
-> IO ([Word64], Map Word64 (Double, Int))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Word64] -> [Word64]
forall a. [a] -> [a]
reverse [Word64]
taken, Map Word64 (Double, Int)
cands)
            | Bool
otherwise = do
                Map Word64 (Double, Int)
passing <- (Word64 -> (Double, Int) -> IO (Maybe (Double, Int)))
-> Map Word64 (Double, Int) -> IO (Map Word64 (Double, Int))
forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
Map.traverseMaybeWithKey (\Word64
v (Double, Int)
c -> (\Bool
ok -> if Bool
ok then (Double, Int) -> Maybe (Double, Int)
forall a. a -> Maybe a
Just (Double, Int)
c else Maybe (Double, Int)
forall a. Maybe a
Nothing) (Bool -> Maybe (Double, Int))
-> IO Bool -> IO (Maybe (Double, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> (Double, Int) -> IO Bool
passes Word64
v (Double, Int)
c) Map Word64 (Double, Int)
cands
                case Map Word64 (Double, Int) -> Maybe (Word64, (Double, Int))
forall {a}. Map a (Double, Int) -> Maybe (a, (Double, Int))
best Map Word64 (Double, Int)
passing of
                  Maybe (Word64, (Double, Int))
Nothing -> ([Word64], Map Word64 (Double, Int))
-> IO ([Word64], Map Word64 (Double, Int))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Word64] -> [Word64]
forall a. [a] -> [a]
reverse [Word64]
taken, Map Word64 (Double, Int)
cands)
                  Just (Word64
v, (Double
w, Int
_)) -> do
                    Bool
claimed <- IO Bool
-> (Ptr NativeCell -> IO Bool) -> Maybe (Ptr NativeCell) -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) Ptr NativeCell -> IO Bool
takeNativeCell (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
v EnumMap Word64 MCombs
cache Maybe MCombs
-> (MCombs -> Maybe (Ptr NativeCell)) -> Maybe (Ptr NativeCell)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MCombs -> Maybe (Ptr NativeCell)
entryCell)
                    let seen' :: Set Word64
seen' = Word64 -> Set Word64 -> Set Word64
forall a. Ord a => a -> Set a -> Set a
Set.insert Word64
v Set Word64
seen
                        cands' :: Map Word64 (Double, Int)
cands' = Word64 -> Map Word64 (Double, Int) -> Map Word64 (Double, Int)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Word64
v Map Word64 (Double, Int)
cands
                    if Bool
claimed
                      then do
                        Config -> [Char] -> IO ()
jitLog Config
config ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" joins the batch for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", weight " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
w)
                        Word64
-> (Set Word64, Map Word64 (Double, Int))
-> IO (Map Word64 (Double, Int))
expand Word64
v (Set Word64
seen', Map Word64 (Double, Int)
cands') IO (Map Word64 (Double, Int))
-> (Map Word64 (Double, Int)
    -> IO ([Word64], Map Word64 (Double, Int)))
-> IO ([Word64], Map Word64 (Double, Int))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Word64]
-> Set Word64
-> Map Word64 (Double, Int)
-> IO ([Word64], Map Word64 (Double, Int))
go (Word64
v Word64 -> [Word64] -> [Word64]
forall a. a -> [a] -> [a]
: [Word64]
taken) Set Word64
seen'
                      else [Word64]
-> Set Word64
-> Map Word64 (Double, Int)
-> IO ([Word64], Map Word64 (Double, Int))
go [Word64]
taken Set Word64
seen' Map Word64 (Double, Int)
cands'
      Map Word64 (Double, Int)
cands0 <- Word64
-> (Set Word64, Map Word64 (Double, Int))
-> IO (Map Word64 (Double, Int))
expand Word64
grp (Word64 -> Set Word64
forall a. a -> Set a
Set.singleton Word64
grp, Map Word64 (Double, Int)
forall k a. Map k a
Map.empty)
      ([Word64]
members, Map Word64 (Double, Int)
left) <- [Word64]
-> Set Word64
-> Map Word64 (Double, Int)
-> IO ([Word64], Map Word64 (Double, Int))
go [Word64
grp] (Word64 -> Set Word64
forall a. a -> Set a
Set.singleton Word64
grp) Map Word64 (Double, Int)
cands0
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
logging Config
config Bool -> Bool -> Bool
&& Bool -> Bool
not (Map Word64 (Double, Int) -> Bool
forall k a. Map k a -> Bool
Map.null Map Word64 (Double, Int)
left)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Config -> [Char] -> IO ()
jitLog Config
config ([Char]
"  left out of the batch for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
grp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (weight " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show Double
w [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")" | (Word64
v, (Double
w, Int
_)) <- Map Word64 (Double, Int) -> [(Word64, (Double, Int))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word64 (Double, Int)
left])
      pure [Word64]
members
    -- The compiled callees of the batch that are worth a private copy in
    -- its module (see 'copyUnits'): those where a call is a real share of
    -- the work per call, by the estimate's path saving, and that don't
    -- loop or recurse (a copy of those would stay as a second body and
    -- gain only the outer call).
    copyCandidates :: Bool
-> EnumMap Word64 MCombs
-> EnumMap Word64 Reference
-> [Word64]
-> IO [Unit]
copyCandidates Bool
sandbox EnumMap Word64 MCombs
cache EnumMap Word64 Reference
refs [Word64]
members
      | Config -> Double
copyBound Config
config Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 Bool -> Bool -> Bool
|| [Char]
"copy" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Config -> [[Char]]
disabled Config
config = [Unit] -> IO [Unit]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise = do
          let inBatch :: Set Word64
inBatch = [Word64] -> Set Word64
forall a. Ord a => [a] -> Set a
Set.fromList [Word64]
members
              callees :: [Word64]
callees = Set Word64 -> [Word64]
forall a. Set a -> [a]
Set.toList ([Word64] -> Set Word64
forall a. Ord a => [a] -> Set a
Set.fromList [Word64
d | Word64
g <- [Word64]
members, Just MCombs
cmbs <- [Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
g EnumMap Word64 MCombs
cache], Word64
d <- Word64 -> MCombs -> [Word64]
groupDeps Word64
g MCombs
cmbs, Bool -> Bool
not (Word64 -> Set Word64 -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Word64
d Set Word64
inBatch)])
          [[Unit]]
picked <- [Word64] -> (Word64 -> IO [Unit]) -> IO [[Unit]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word64]
callees ((Word64 -> IO [Unit]) -> IO [[Unit]])
-> (Word64 -> IO [Unit]) -> IO [[Unit]]
forall a b. (a -> b) -> a -> b
$ \Word64
d -> case (Word64 -> EnumMap Word64 MCombs -> Maybe MCombs
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
d EnumMap Word64 MCombs
cache, Word64 -> EnumMap Word64 Reference -> Maybe Reference
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
d EnumMap Word64 Reference
refs) of
            (Just MCombs
cmbs, Just Reference
ref)
              | Just Ptr NativeCell
cell <- MCombs -> Maybe (Ptr NativeCell)
entryCell MCombs
cmbs,
                Just (Comb (LamI Int
_ Int
_ GSection (RComb Val)
entry Ptr NativeCell
_)) <- Word64 -> MCombs -> Maybe (GComb Val (RComb Val))
forall k a. EnumKey k => k -> EnumMap k a -> Maybe a
EC.lookup Word64
0 MCombs
cmbs -> do
                  Ptr ()
code <- Ptr NativeCell -> IO (Ptr ())
readNativeCode Ptr NativeCell
cell
                  if Ptr ()
code Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr
                    then [Unit] -> IO [Unit]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                    else do
                      (Bool
_, Maybe Estimate
est) <- Config
-> Ptr NativeCell
-> GSection (RComb Val)
-> IO (Bool, Maybe Estimate)
judge Config
config Ptr NativeCell
cell GSection (RComb Val)
entry
                      case Maybe Estimate
est of
                        Just (Estimate Double
saving Double
_ Bool
False) | Double
saving Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Config -> Double
copyBound Config
config -> Compiler -> Bool -> Reference -> Word64 -> MCombs -> IO [Unit]
copyUnits Compiler
c Bool
sandbox Reference
ref Word64
d MCombs
cmbs
                        Maybe Estimate
_ -> [Unit] -> IO [Unit]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            (Maybe MCombs, Maybe Reference)
_ -> [Unit] -> IO [Unit]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          let units :: [Unit]
units = Int -> [Unit] -> [Unit]
forall a. Int -> [a] -> [a]
take (Config -> Int
batch Config
config) ([[Unit]] -> [Unit]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Unit]]
picked)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Unit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Unit]
units) (Config -> [Char] -> IO ()
jitLog Config
config ([Char]
"private copies: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Unit -> [Char]) -> [Unit] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Unit -> [Char]
unitName [Unit]
units)))
          pure [Unit]
units

-- | Runs a compile step, logging an exception instead of letting it escape:
-- a failure to compile (or to write a dump file) must never take the
-- program down, since the interpreter can run anything.
guarded :: Config -> String -> IO () -> IO ()
guarded :: Config -> [Char] -> IO () -> IO ()
guarded Config
config [Char]
what IO ()
act =
  IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ()
act IO () -> (() -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= () -> IO ()
forall a. a -> IO a
evaluate) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (SomeException
e :: SomeException) -> Config -> [Char] -> IO ()
jitLog Config
config ([Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e)
    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Prints how often each exit was taken, when UNISON_JIT_STATS is set.
-- Called after each evaluation.
printJITStats :: JIT -> IO ()
printJITStats :: JIT -> IO ()
printJITStats JIT
jit = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
stats Config
config) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  CompileTotals
t <- Compiler -> IO CompileTotals
compileTotals (JIT -> Compiler
jitCompiler JIT
jit)
  [Char] -> IO ()
jitDump
    ( [Char]
"[jit] compiled "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctModules CompileTotals
t)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" modules: "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctFunctions CompileTotals
t)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" functions, "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctAuxiliary CompileTotals
t)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" auxiliary functions with them, "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctOnDemand CompileTotals
t)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" re-entry functions on demand ("
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctPending CompileTotals
t)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" never asked for); "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctNotWorthIt CompileTotals
t)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" left interpreted by the exit rule; "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (CompileTotals -> Int
ctIRBytes CompileTotals
t Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1024)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" KB of IR, "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CompileTotals -> Word64
ctNanoseconds CompileTotals
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ms"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (generate "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CompileTotals -> Word64
ctGenerate CompileTotals
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", parse and optimize "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CompileTotals -> Word64
ctOptimize CompileTotals
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", code "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CompileTotals -> Word64
ctCodegen CompileTotals
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    )
  AdHoc
a <- IORef AdHoc -> IO AdHoc
forall a. IORef a -> IO a
readIORef (JIT -> IORef AdHoc
jitAdHoc JIT
jit)
  [Char] -> IO ()
jitDump
    ( [Char]
"[jit] ad hoc exits (the poll, stack growth): "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (AdHoc -> Int
ahRequested AdHoc
a)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" re-entry functions asked for, "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (AdHoc -> Int
ahRefused AdHoc
a)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" exits through an uncompiled Let past the cap"
    )
  JIT -> Int -> IO ()
printExits JIT
jit Int
forall a. Bounded a => a
maxBound
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
statsEach Config
config) (Exits -> IO ()
resetExitCounts (JIT -> Exits
jitExits JIT
jit))
  where
    config :: Config
config = JIT -> Config
jitConfig JIT
jit

-- | Called by the interpreter after each foreign call. With
-- @UNISON_JIT_STATS=each@, a call that wrote output is followed by the
-- exits taken since the program last wrote (the busiest sites only), after
-- which counting starts again; so a program that prints a line per phase
-- gets its exits listed per phase.
noteOutput :: JIT -> ForeignFunc -> IO ()
noteOutput :: JIT -> ForeignFunc -> IO ()
noteOutput JIT
jit ForeignFunc
f =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
statsEach (JIT -> Config
jitConfig JIT
jit) Bool -> Bool -> Bool
&& ForeignFunc
f ForeignFunc -> ForeignFunc -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignFunc
IO_putBytes_impl_v3) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Handle -> IO ()
hFlush Handle
stdout
    JIT -> Int -> IO ()
printExits JIT
jit Int
12
    Exits -> IO ()
resetExitCounts (JIT -> Exits
jitExits JIT
jit)

printExits :: JIT -> Int -> IO ()
printExits :: JIT -> Int -> IO ()
printExits JIT
jit Int
most = do
  [([Char], Int)]
entered <- Exits -> IO [([Char], Int)]
entryCounts (JIT -> Exits
jitExits JIT
jit)
  let enteredTotal :: Int
enteredTotal = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((([Char], Int) -> Int) -> [([Char], Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Int) -> Int
forall a b. (a, b) -> b
snd [([Char], Int)]
entered)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
enteredTotal Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
jitDump ([Char]
"[jit] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
enteredTotal [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" entries into native code from the trampoline (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([([Char], Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Char], Int)]
entered) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" functions):")
    [([Char], Int)] -> (([Char], Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [([Char], Int)] -> [([Char], Int)]
forall a. Int -> [a] -> [a]
take Int
most ((([Char], Int) -> Int) -> [([Char], Int)] -> [([Char], Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (([Char], Int) -> Int) -> ([Char], Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Int) -> Int
forall a b. (a, b) -> b
snd) [([Char], Int)]
entered)) ((([Char], Int) -> IO ()) -> IO ())
-> (([Char], Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Int
n) ->
      [Char] -> IO ()
jitDump ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name)
  [(Int, Exit, Int)]
counts <- Exits -> IO [(Int, Exit, Int)]
exitCounts (JIT -> Exits
jitExits JIT
jit)
  let total :: Int
total = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
n | (Int
_, Exit
_, Int
n) <- [(Int, Exit, Int)]
counts]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
jitDump ([Char]
"[jit] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
total [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" exits taken (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([(Int, Exit, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Exit, Int)]
counts) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" sites):")
    [(Int, Exit, Int)] -> ((Int, Exit, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [(Int, Exit, Int)] -> [(Int, Exit, Int)]
forall a. Int -> [a] -> [a]
take Int
most (((Int, Exit, Int) -> Int)
-> [(Int, Exit, Int)] -> [(Int, Exit, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Int
_, Exit
_, Int
n) -> Int -> Int
forall a. Num a => a -> a
negate Int
n) [(Int, Exit, Int)]
counts)) (((Int, Exit, Int) -> IO ()) -> IO ())
-> ((Int, Exit, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, Exit
e, Int
n) ->
      [Char] -> IO ()
jitDump ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t#" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\t" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exit -> [Char]
describe Exit
e)
  where
    describe :: Exit -> [Char]
describe = \case
      Resume CombIx
cix GSection (RComb Val)
sect -> [Char]
"resume " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show CombIx
cix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (Int -> GSection (RComb Val) -> [Char] -> [Char]
forall comb. Show comb => Int -> GSection comb -> [Char] -> [Char]
prettySection Int
0 GSection (RComb Val)
sect [Char]
""))
      GrowStack Int
n Ptr NativeCell
_ -> [Char]
"grow stack by " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
      Reenter Ptr NativeCell
_ -> [Char]
"reenter (poll)"
      CallOut CombIx
cix MInstr
instr GSection (RComb Val)
_ Int
_ Ptr NativeCell
_ -> [Char]
"call out " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show CombIx
cix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (MInstr -> [Char] -> [Char]
forall comb. Show comb => GInstr comb -> [Char] -> [Char]
prettyIns MInstr
instr [Char]
"")
      Named [Char]
name Exit
e -> [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exit -> [Char]
describe Exit
e