{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}

-- | Compiling a group of combinators to a native module and installing
-- the result in their cells. See design.md, "What gets compiled, and when".
module Unison.Runtime.JIT.Compile
  ( Compiler (..),
    newCompiler,
    JITState (..),
    Unit,
    unitName,
    groupUnits,
    copyUnits,
    compileUnits,
    addPending,
    lookupPending,
    dropPending,
    CompileTotals (..),
    compileTotals,
  )
where

import Control.Concurrent (threadDelay)
import Control.Monad (forM, forM_, unless, when)
import Data.Bifunctor (first)
import Data.Bits ((.&.))
import Data.Foldable (toList)
import Data.IORef
import Data.Map qualified as Map
import Data.Map.Strict qualified as MapS
import Data.Maybe (isJust)
import Data.Primitive.PrimArray (sizeofPrimArray)
import Data.Set qualified as Set
import Data.Text.IO qualified as TIO
import Data.Word (Word64)
import Foreign.Ptr (Ptr, castFunPtrToPtr)
import GHC.Clock (getMonotonicTimeNSec)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)
import Unison.Builtin.Decls qualified as Ty (eitherRef, optionalRef, pairRef, seqViewRef, unitRef)
import Unison.Reference (Reference)
import Unison.Runtime.ANF (PackedTag (..))
import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..))
import Unison.Runtime.JIT.Codegen (AuxMemo, CtxOffsets, Deferred (..), Function (..), RtsFacts, genDeferred, genFunction, modulePrelude)
import Unison.Runtime.JIT.Codegen qualified as CG
import Unison.Runtime.JIT.Config
import Unison.Runtime.JIT.Estimate (Estimate (..), judge)
import Unison.Runtime.JIT.Exits (Exits, nameEntry, newExits, registerExits, replaceExits)
import Unison.Runtime.JIT.Frames (Frames, newFrames, registerFrames, replaceFrames)
import Unison.Runtime.JIT.LLVM
import Unison.Runtime.JIT.Layout (Layouts)
import Unison.Runtime.JIT.Pool (Pool, PoolKey (..), newPool, poolIndices, poolStableSize)
import Unison.Runtime.JIT.Strict (Pair (..), unlinesT)
import Unison.Runtime.MCode
import Unison.Runtime.Stack (MCombs, MSection, Val (..))
import Unison.Runtime.TypeTags qualified as TT
import Unison.Util.Deque qualified as D
import Unison.Util.EnumContainers qualified as EC
import Unison.Util.Text qualified as UT

-- | Everything in a section tree, innermost sections included, in order.
sectionsOf :: MSection -> [MSection]
sectionsOf :: MSection -> [MSection]
sectionsOf MSection
s = MSection
s MSection -> [MSection] -> [MSection]
forall a. a -> [a] -> [a]
: [MSection]
rest
  where
    rest :: [MSection]
rest = case MSection
s of
      Let MSection
b CombIx
_ Int
_ MSection
bd Ptr NativeCell
_ -> MSection -> [MSection]
sectionsOf MSection
b [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ MSection -> [MSection]
sectionsOf MSection
bd
      Ins GInstr (RComb Val)
_ MSection
nx -> MSection -> [MSection]
sectionsOf MSection
nx
      Match Int
_ GBranch (RComb Val)
bs -> GBranch (RComb Val) -> [MSection]
goB GBranch (RComb Val)
bs
      DMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
bs -> GBranch (RComb Val) -> [MSection]
goB GBranch (RComb Val)
bs
      NMatch Maybe Reference
_ Int
_ GBranch (RComb Val)
bs -> GBranch (RComb Val) -> [MSection]
goB GBranch (RComb Val)
bs
      RMatch Int
_ MSection
p EnumMap Word64 (GBranch (RComb Val))
bs -> MSection -> [MSection]
sectionsOf MSection
p [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ (GBranch (RComb Val) -> [MSection])
-> [GBranch (RComb Val)] -> [MSection]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GBranch (RComb Val) -> [MSection]
goB (((Word64, GBranch (RComb Val)) -> GBranch (RComb Val))
-> [(Word64, GBranch (RComb Val))] -> [GBranch (RComb Val)]
forall a b. (a -> b) -> [a] -> [b]
map (Word64, GBranch (RComb Val)) -> GBranch (RComb Val)
forall a b. (a, b) -> b
snd (EnumMap Word64 (GBranch (RComb Val))
-> [(Word64, GBranch (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (GBranch (RComb Val))
bs))
      -- no sections inside these
      Call {} -> []
      App {} -> []
      Yield {} -> []
      Jump {} -> []
      Die {} -> []
      MSection
Exit -> []
    goB :: GBranch (RComb Val) -> [MSection]
goB = \case
      Test1 Word64
_ (Arm Int
_ MSection
a) MSection
d -> MSection -> [MSection]
sectionsOf MSection
a [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ MSection -> [MSection]
sectionsOf MSection
d
      Test2 Word64
_ (Arm Int
_ MSection
a) Word64
_ (Arm Int
_ MSection
b) MSection
d -> MSection -> [MSection]
sectionsOf MSection
a [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ MSection -> [MSection]
sectionsOf MSection
b [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ MSection -> [MSection]
sectionsOf MSection
d
      TestW MSection
d EnumMap Word64 (Arm (RComb Val))
m -> MSection -> [MSection]
sectionsOf MSection
d [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ ((Word64, Arm (RComb Val)) -> [MSection])
-> [(Word64, Arm (RComb Val))] -> [MSection]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (MSection -> [MSection]
sectionsOf (MSection -> [MSection])
-> ((Word64, Arm (RComb Val)) -> MSection)
-> (Word64, Arm (RComb Val))
-> [MSection]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arm (RComb Val) -> MSection
forall comb. Arm comb -> GSection comb
armSection (Arm (RComb Val) -> MSection)
-> ((Word64, Arm (RComb Val)) -> Arm (RComb Val))
-> (Word64, Arm (RComb Val))
-> MSection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, Arm (RComb Val)) -> Arm (RComb Val)
forall a b. (a, b) -> b
snd) (EnumMap Word64 (Arm (RComb Val)) -> [(Word64, Arm (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 (Arm (RComb Val))
m)
      TestT MSection
d Map Text MSection
m -> MSection -> [MSection]
sectionsOf MSection
d [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ (MSection -> [MSection]) -> [MSection] -> [MSection]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap MSection -> [MSection]
sectionsOf (Map Text MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Text MSection
m)
      TestY MSection
d Map Bytes MSection
m -> MSection -> [MSection]
sectionsOf MSection
d [MSection] -> [MSection] -> [MSection]
forall a. [a] -> [a] -> [a]
++ (MSection -> [MSection]) -> [MSection] -> [MSection]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap MSection -> [MSection]
sectionsOf (Map Bytes MSection -> [MSection]
forall k a. Map k a -> [a]
Map.elems Map Bytes MSection
m)

-- | The cells carried by every Let in a section tree.
letCellsOf :: MSection -> [Ptr NativeCell]
letCellsOf :: MSection -> [Ptr NativeCell]
letCellsOf MSection
s = [Ptr NativeCell
c | Let MSection
_ CombIx
_ Int
_ MSection
_ Ptr NativeCell
c <- MSection -> [MSection]
sectionsOf MSection
s]

-- | The constants a section tree needs from the pool.
poolKeysOf :: MSection -> [PoolKey]
poolKeysOf :: MSection -> [PoolKey]
poolKeysOf MSection
s =
  [[PoolKey]] -> [PoolKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [GInstr (RComb Val) -> [PoolKey]
keys GInstr (RComb Val)
i | Ins GInstr (RComb Val)
i MSection
_ <- MSection -> [MSection]
sectionsOf MSection
s]
    [PoolKey] -> [PoolKey] -> [PoolKey]
forall a. [a] -> [a] -> [a]
++ [[PoolKey]] -> [PoolKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [GRef (RComb Val) -> [PoolKey]
combKey GRef (RComb Val)
r | App Bool
_ GRef (RComb Val)
r Args
ZArgs <- MSection -> [MSection]
sectionsOf MSection
s]
    [PoolKey] -> [PoolKey] -> [PoolKey]
forall a. [a] -> [a] -> [a]
++ [[PoolKey]] -> [PoolKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [CombIx -> RComb Val -> [PoolKey]
cachedKey CombIx
cix RComb Val
comb | Call Bool
_ CombIx
cix RComb Val
comb Args
ZArgs <- MSection -> [MSection]
sectionsOf MSection
s]
    -- a function applied to fewer arguments than it takes: the partial
    -- application is built from the function's closure
    [PoolKey] -> [PoolKey] -> [PoolKey]
forall a. [a] -> [a] -> [a]
++ [ CombIx -> GCombInfo (RComb Val) -> PoolKey
KeyComb CombIx
cix GCombInfo (RComb Val)
info
       | App Bool
_ (Env CombIx
cix RComb Val
comb) Args
args <- MSection -> [MSection]
sectionsOf MSection
s,
         Comb info :: GCombInfo (RComb Val)
info@(LamI Int
arity Int
_ MSection
_ Ptr NativeCell
_) <- [RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb],
         Just Int
n <- [Args -> Maybe Int
argCount Args
args],
         Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0,
         Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arity
       ]
  where
    -- the constructors the text and bytes helpers build results from
    none :: PoolKey
none = Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.optionalRef PackedTag
TT.noneTag
    pair :: PoolKey
pair = Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
0)
    unit :: PoolKey
unit = Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag
    -- a known combinator used as a value, or a top-level value
    combKey :: GRef (RComb Val) -> [PoolKey]
combKey = \case
      Env CombIx
cix RComb Val
comb
        | Comb GCombInfo (RComb Val)
info <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb -> [CombIx -> GCombInfo (RComb Val) -> PoolKey
KeyComb CombIx
cix GCombInfo (RComb Val)
info]
        | Bool
otherwise -> CombIx -> RComb Val -> [PoolKey]
cachedKey CombIx
cix RComb Val
comb
      GRef (RComb Val)
_ -> []
    cachedKey :: CombIx -> RComb Val -> [PoolKey]
cachedKey CombIx
cix RComb Val
comb = case RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb of
      CachedVal Word64
_ Val
v -> [CombIx -> Closure -> PoolKey
KeyCached CombIx
cix (Val -> Closure
getBoxedVal Val
v)]
      GComb Val (RComb Val)
_ -> []
    argCount :: Args -> Maybe Int
argCount = \case
      Args
ZArgs -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
      VArg1 Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
      VArg2 Int
_ Int
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
      VArgR Int
_ Int
l -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l
      VArgN PrimArray Int
v -> Int -> Maybe Int
forall a. a -> Maybe a
Just (PrimArray Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
v)
      VArgV Int
_ -> Maybe Int
forall a. Maybe a
Nothing
    keys :: GInstr (RComb Val) -> [PoolKey]
keys = \case
      Pack Reference
r PackedTag
t Args
ZArgs -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
r PackedTag
t]
      Pack Reference
r PackedTag
_ Args
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
r (Word64 -> PackedTag
PackedTag Word64
0)]
      -- a record is built from an empty one of its shape
      RecPack RecordShape
shape Args
_ -> [RecordShape -> PoolKey
KeyRecord RecordShape
shape]
      Lit l :: MLit
l@(MT Text
_) -> [MLit -> PoolKey
KeyLit MLit
l]
      Lit l :: MLit
l@(MM Referent
_) -> [MLit -> PoolKey
KeyLit MLit
l]
      Lit l :: MLit
l@(MY Reference
_) -> [MLit -> PoolKey
KeyLit MLit
l]
      Prim2 Prim2
REFW Int
_ Int
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag]
      -- the list helpers are handed the result type's field-less constructor
      Prim1 Prim1
VWLS Int
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag]
      Prim1 Prim1
VWRS Int
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag]
      Prim2 Prim2
IDXS Int
_ Int
_ -> [PoolKey
none]
      Prim2 Prim2
IDXB Int
_ Int
_ -> [PoolKey
none]
      Prim2 Prim2
IXOT Int
_ Int
_ -> [PoolKey
none]
      Prim2 Prim2
IXOB Int
_ Int
_ -> [PoolKey
none]
      Prim1 Prim1
UCNS Int
_ -> [PoolKey
none, PoolKey
pair, PoolKey
unit]
      Prim1 Prim1
USNC Int
_ -> [PoolKey
none, PoolKey
pair, PoolKey
unit]
      Prim1 Prim1
TTOI Int
_ -> [PoolKey
none]
      Prim1 Prim1
TTON Int
_ -> [PoolKey
none]
      Prim1 Prim1
TTOF Int
_ -> [PoolKey
none]
      ForeignCall Bool
_ ForeignFunc
f Args
_
        | ForeignFunc
f ForeignFunc -> [ForeignFunc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ForeignFunc
Bytes_decodeNat16be, ForeignFunc
Bytes_decodeNat16le, ForeignFunc
Bytes_decodeNat32be, ForeignFunc
Bytes_decodeNat32le, ForeignFunc
Bytes_decodeNat64be, ForeignFunc
Bytes_decodeNat64le] -> [PoolKey
none, PoolKey
pair, PoolKey
unit]
        | ForeignFunc
f ForeignFunc -> [ForeignFunc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ForeignFunc
Text_fromUtf8_impl_v3, ForeignFunc
Bytes_fromBase16, ForeignFunc
Bytes_fromBase32, ForeignFunc
Bytes_fromBase64, ForeignFunc
Bytes_fromBase64UrlUnpadded] -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.eitherRef (Word64 -> PackedTag
PackedTag Word64
0)]
      Prim2 Prim2
SPLL Int
_ Int
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag]
      Prim2 Prim2
SPLR Int
_ Int
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag]
      -- a partial application of a known function starts from its closure
      Name (Env CombIx
cix RComb Val
comb) Args
_ | Comb GCombInfo (RComb Val)
info <- RComb Val -> GComb Val (RComb Val)
forall val. RComb val -> GComb val (RComb val)
unRComb RComb Val
comb -> [CombIx -> GCombInfo (RComb Val) -> PoolKey
KeyComb CombIx
cix GCombInfo (RComb Val)
info]
      ForeignCall Bool
_ ForeignFunc
MutableArray_write Args
_ -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag]
      -- the array writes and copies give unit
      ForeignCall Bool
_ ForeignFunc
f Args
_ | ForeignFunc
f ForeignFunc -> [ForeignFunc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ForeignFunc]
CG.unitForeign -> [Reference -> PackedTag -> PoolKey
KeyEnum Reference
Ty.unitRef PackedTag
TT.unitTag]
      GInstr (RComb Val)
_ -> []

-- | What compilation needs, found once at startup.
data JITState = JITState
  { JITState -> Layouts
jsLayouts :: Layouts,
    JITState -> CtxOffsets
jsCtx :: CtxOffsets,
    JITState -> RtsFacts
jsRts :: RtsFacts
  }

-- | One LLVM function to generate, with what it brings along: a
-- combinator, or a re-entry function that was left for later.
data Unit = Unit
  { -- | the LLVM function's name
    Unit -> [Char]
uName :: String,
    -- | the combinator-level function this belongs to (itself, for a
    -- combinator): re-entry functions generated at different times for
    -- the same root share one table of cells
    Unit -> [Char]
uRoot :: String,
    Unit -> Ptr NativeCell
uCell :: Ptr NativeCell,
    -- | the group the code is from, for the arity of Let body combinators
    Unit -> MCombs
uCombs :: MCombs,
    Unit -> MSection
uSection :: MSection,
    -- | for the IR dump: what this is, and its MCode
    Unit -> [Char]
uDescribe :: String,
    -- | a re-entry function that waits to be asked for
    Unit -> Bool
uOnDemand :: Bool,
    -- | the arity, for a combinator that can have a worker (an entry
    -- point or local function whose returns all yield one value)
    Unit -> Maybe Int
uWorker :: Maybe Int,
    -- | a private copy of a callee compiled earlier: it exists so that
    -- the module's calls to it are direct (and may be inlined), is not
    -- installed in its cell (the earlier code stays for everyone else),
    -- and has internal linkage, so LLVM drops it once it is inlined away
    Unit -> Bool
uCopy :: Bool,
    -- | the code cache this came from is sandboxed: the operations the
    -- interpreter refuses in a sandbox (Ref.cas and its ticket read) are
    -- left to it
    Unit -> Bool
uSandboxed :: Bool,
    -- | generates the function under the given symbol
    Unit -> [Char] -> Env -> Either [Char] Function
uGen :: String -> CG.Env -> Either String Function
  }

unitName :: Unit -> String
unitName :: Unit -> [Char]
unitName = Unit -> [Char]
uName

-- | What compiling needs and what it keeps between compilations: the
-- settings, the tables generated code refers to by index, and the state
-- below. One per JIT (which is one per process; see JIT.hs).
data Compiler = Compiler
  { Compiler -> Config
cConfig :: !Config,
    Compiler -> Exits
cExits :: !Exits,
    Compiler -> Frames
cFrames :: !Frames,
    Compiler -> Pool
cPool :: !Pool,
    -- | Re-entry functions that have a cell but no code yet, by cell. The
    -- interpreter counts the times it finds such a cell empty; when the
    -- count says the re-entry point is used, the unit is found here and
    -- queued for compilation. The cell's request state keeps it from being
    -- queued twice.
    Compiler -> IORef (Map (Ptr NativeCell) Unit)
cPending :: !(IORef (Map.Map (Ptr NativeCell) Unit)),
    Compiler -> IORef CompileTotals
cTotals :: !(IORef CompileTotals),
    -- | the auxiliary functions known for each root function (see 'uRoot')
    Compiler -> IORef (Map [Char] AuxMemo)
cRootMemos :: !(IORef (Map.Map String AuxMemo)),
    -- | for each group number, the first cell of every group seen with
    -- that number (see 'groupUnits')
    Compiler -> IORef (Map Word64 [Ptr NativeCell])
cGroupCells :: !(IORef (Map.Map Word64 [Ptr NativeCell])),
    -- | numbers the private copies, so that their symbols are unique in
    -- the process (a group's own names are unique, a copy of it can be
    -- made by several modules)
    Compiler -> IORef Int
cCopyCounter :: !(IORef Int)
  }

newCompiler :: Config -> IO Compiler
newCompiler :: Config -> IO Compiler
newCompiler Config
config =
  Config
-> Exits
-> Frames
-> Pool
-> IORef (Map (Ptr NativeCell) Unit)
-> IORef CompileTotals
-> IORef (Map [Char] AuxMemo)
-> IORef (Map Word64 [Ptr NativeCell])
-> IORef Int
-> Compiler
Compiler Config
config
    (Exits
 -> Frames
 -> Pool
 -> IORef (Map (Ptr NativeCell) Unit)
 -> IORef CompileTotals
 -> IORef (Map [Char] AuxMemo)
 -> IORef (Map Word64 [Ptr NativeCell])
 -> IORef Int
 -> Compiler)
-> IO Exits
-> IO
     (Frames
      -> Pool
      -> IORef (Map (Ptr NativeCell) Unit)
      -> IORef CompileTotals
      -> IORef (Map [Char] AuxMemo)
      -> IORef (Map Word64 [Ptr NativeCell])
      -> IORef Int
      -> Compiler)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO Exits
newExits (Config -> Bool
stats Config
config)
    IO
  (Frames
   -> Pool
   -> IORef (Map (Ptr NativeCell) Unit)
   -> IORef CompileTotals
   -> IORef (Map [Char] AuxMemo)
   -> IORef (Map Word64 [Ptr NativeCell])
   -> IORef Int
   -> Compiler)
-> IO Frames
-> IO
     (Pool
      -> IORef (Map (Ptr NativeCell) Unit)
      -> IORef CompileTotals
      -> IORef (Map [Char] AuxMemo)
      -> IORef (Map Word64 [Ptr NativeCell])
      -> IORef Int
      -> Compiler)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Frames
newFrames
    IO
  (Pool
   -> IORef (Map (Ptr NativeCell) Unit)
   -> IORef CompileTotals
   -> IORef (Map [Char] AuxMemo)
   -> IORef (Map Word64 [Ptr NativeCell])
   -> IORef Int
   -> Compiler)
-> IO Pool
-> IO
     (IORef (Map (Ptr NativeCell) Unit)
      -> IORef CompileTotals
      -> IORef (Map [Char] AuxMemo)
      -> IORef (Map Word64 [Ptr NativeCell])
      -> IORef Int
      -> Compiler)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int -> IO Pool
newPool (Config -> Maybe Int
stressPool Config
config)
    IO
  (IORef (Map (Ptr NativeCell) Unit)
   -> IORef CompileTotals
   -> IORef (Map [Char] AuxMemo)
   -> IORef (Map Word64 [Ptr NativeCell])
   -> IORef Int
   -> Compiler)
-> IO (IORef (Map (Ptr NativeCell) Unit))
-> IO
     (IORef CompileTotals
      -> IORef (Map [Char] AuxMemo)
      -> IORef (Map Word64 [Ptr NativeCell])
      -> IORef Int
      -> Compiler)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map (Ptr NativeCell) Unit -> IO (IORef (Map (Ptr NativeCell) Unit))
forall a. a -> IO (IORef a)
newIORef Map (Ptr NativeCell) Unit
forall k a. Map k a
Map.empty
    IO
  (IORef CompileTotals
   -> IORef (Map [Char] AuxMemo)
   -> IORef (Map Word64 [Ptr NativeCell])
   -> IORef Int
   -> Compiler)
-> IO (IORef CompileTotals)
-> IO
     (IORef (Map [Char] AuxMemo)
      -> IORef (Map Word64 [Ptr NativeCell]) -> IORef Int -> Compiler)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CompileTotals -> IO (IORef CompileTotals)
forall a. a -> IO (IORef a)
newIORef (Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Word64
-> Word64
-> Word64
-> Word64
-> CompileTotals
CompileTotals Int
0 Int
0 Int
0 Int
0 Int
0 Int
0 Int
0 Int
0 Word64
0 Word64
0 Word64
0 Word64
0)
    IO
  (IORef (Map [Char] AuxMemo)
   -> IORef (Map Word64 [Ptr NativeCell]) -> IORef Int -> Compiler)
-> IO (IORef (Map [Char] AuxMemo))
-> IO
     (IORef (Map Word64 [Ptr NativeCell]) -> IORef Int -> Compiler)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map [Char] AuxMemo -> IO (IORef (Map [Char] AuxMemo))
forall a. a -> IO (IORef a)
newIORef Map [Char] AuxMemo
forall k a. Map k a
Map.empty
    IO (IORef (Map Word64 [Ptr NativeCell]) -> IORef Int -> Compiler)
-> IO (IORef (Map Word64 [Ptr NativeCell]))
-> IO (IORef Int -> Compiler)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Word64 [Ptr NativeCell]
-> IO (IORef (Map Word64 [Ptr NativeCell]))
forall a. a -> IO (IORef a)
newIORef Map Word64 [Ptr NativeCell]
forall k a. Map k a
Map.empty
    IO (IORef Int -> Compiler) -> IO (IORef Int) -> IO Compiler
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0

addPending :: Compiler -> Unit -> IO ()
addPending :: Compiler -> Unit -> IO ()
addPending Compiler
c Unit
u = do
  Ptr NativeCell -> Int -> IO ()
writeNativeCount (Unit -> Ptr NativeCell
uCell Unit
u) (Int -> Int
forall a. Num a => a -> a
negate (Config -> Int
threshold (Compiler -> Config
cConfig Compiler
c)))
  IORef (Map (Ptr NativeCell) Unit)
-> (Map (Ptr NativeCell) Unit -> (Map (Ptr NativeCell) Unit, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef (Map (Ptr NativeCell) Unit)
cPending Compiler
c) (\Map (Ptr NativeCell) Unit
m -> (Ptr NativeCell
-> Unit -> Map (Ptr NativeCell) Unit -> Map (Ptr NativeCell) Unit
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Unit -> Ptr NativeCell
uCell Unit
u) Unit
u Map (Ptr NativeCell) Unit
m, ()))

lookupPending :: Compiler -> Ptr NativeCell -> IO (Maybe Unit)
lookupPending :: Compiler -> Ptr NativeCell -> IO (Maybe Unit)
lookupPending Compiler
c Ptr NativeCell
cell = Ptr NativeCell -> Map (Ptr NativeCell) Unit -> Maybe Unit
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr NativeCell
cell (Map (Ptr NativeCell) Unit -> Maybe Unit)
-> IO (Map (Ptr NativeCell) Unit) -> IO (Maybe Unit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map (Ptr NativeCell) Unit) -> IO (Map (Ptr NativeCell) Unit)
forall a. IORef a -> IO a
readIORef (Compiler -> IORef (Map (Ptr NativeCell) Unit)
cPending Compiler
c)

-- | Forgets a unit that has been dealt with.
dropPending :: Compiler -> Unit -> IO ()
dropPending :: Compiler -> Unit -> IO ()
dropPending Compiler
c Unit
u = IORef (Map (Ptr NativeCell) Unit)
-> (Map (Ptr NativeCell) Unit -> (Map (Ptr NativeCell) Unit, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef (Map (Ptr NativeCell) Unit)
cPending Compiler
c) (\Map (Ptr NativeCell) Unit
m -> (Ptr NativeCell
-> Map (Ptr NativeCell) Unit -> Map (Ptr NativeCell) Unit
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Unit -> Ptr NativeCell
uCell Unit
u) Map (Ptr NativeCell) Unit
m, ()))

-- | What has been compiled so far, for @UNISON_JIT_STATS@.
data CompileTotals = CompileTotals
  { -- | modules handed to LLVM
    CompileTotals -> Int
ctModules :: !Int,
    -- | functions for combinators, auxiliary functions generated with
    -- them, and re-entry functions generated later, on demand
    CompileTotals -> Int
ctFunctions, CompileTotals -> Int
ctAuxiliary, CompileTotals -> Int
ctOnDemand :: !Int,
    -- | private copies of compiled callees (see 'uCopy')
    CompileTotals -> Int
ctCopies :: !Int,
    -- | re-entry functions still waiting to be asked for
    CompileTotals -> Int
ctPending :: !Int,
    -- | functions left to the interpreter because native code for them
    -- would mostly exit (see JIT.Estimate)
    CompileTotals -> Int
ctNotWorthIt :: !Int,
    CompileTotals -> Int
ctIRBytes :: !Int,
    -- | time spent in all, and of that: generating the IR (judging the
    -- units, both passes of the generator, the text), in LLVM's parser
    -- and optimizer (@addModule@), and in its code generator (the
    -- lookups, since LLJIT compiles a module when its first symbol is
    -- looked up)
    CompileTotals -> Word64
ctNanoseconds, CompileTotals -> Word64
ctGenerate, CompileTotals -> Word64
ctOptimize, CompileTotals -> Word64
ctCodegen :: !Word64
  }

compileTotals :: Compiler -> IO CompileTotals
compileTotals :: Compiler -> IO CompileTotals
compileTotals Compiler
c = do
  CompileTotals
t <- IORef CompileTotals -> IO CompileTotals
forall a. IORef a -> IO a
readIORef (Compiler -> IORef CompileTotals
cTotals Compiler
c)
  Int
n <- Map (Ptr NativeCell) Unit -> Int
forall k a. Map k a -> Int
Map.size (Map (Ptr NativeCell) Unit -> Int)
-> IO (Map (Ptr NativeCell) Unit) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map (Ptr NativeCell) Unit) -> IO (Map (Ptr NativeCell) Unit)
forall a. IORef a -> IO a
readIORef (Compiler -> IORef (Map (Ptr NativeCell) Unit)
cPending Compiler
c)
  pure CompileTotals
t {ctPending = n}

-- | The units of one top-level definition: those to compile now, and those
-- to compile when they turn out to be used. Entry points and local
-- functions (zero in the low bits of their number) are compiled now. A Let
-- body combinator is a re-entry point, entered only through the cell its
-- Let carries when the Let's binding left native code: when @lazy@, it
-- waits until that has happened often enough. Let body combinators that no
-- Let refers to (the ones inside bindings) are never entered.
--
-- Function names must be unique in the process, and group numbers aren't
-- when a second runtime (with a code cache of its own) is started: the
-- names of a group whose number has been seen with different cells get a
-- suffix.
groupUnits :: Compiler -> Bool -> Bool -> Reference -> Word64 -> MCombs -> IO ([Unit], [Unit])
groupUnits :: Compiler
-> Bool
-> Bool
-> Reference
-> Word64
-> MCombs
-> IO ([Unit], [Unit])
groupUnits Compiler
c Bool
sandbox Bool
lazy Reference
ref Word64
grp MCombs
combs = do
  [Char]
suffix <- case [Ptr NativeCell
cell | (Word64
_, Int
_, Int
_, MSection
_, Ptr NativeCell
cell) <- [(Word64, Int, Int, MSection, Ptr NativeCell)]
every] of
    [] -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
    Ptr NativeCell
first : [Ptr NativeCell]
_ -> IORef (Map Word64 [Ptr NativeCell])
-> (Map Word64 [Ptr NativeCell]
    -> (Map Word64 [Ptr NativeCell], [Char]))
-> IO [Char]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef (Map Word64 [Ptr NativeCell])
cGroupCells Compiler
c) ((Map Word64 [Ptr NativeCell]
  -> (Map Word64 [Ptr NativeCell], [Char]))
 -> IO [Char])
-> (Map Word64 [Ptr NativeCell]
    -> (Map Word64 [Ptr NativeCell], [Char]))
-> IO [Char]
forall a b. (a -> b) -> a -> b
$ \Map Word64 [Ptr NativeCell]
m ->
      let seen :: [Ptr NativeCell]
seen = [Ptr NativeCell]
-> Word64 -> Map Word64 [Ptr NativeCell] -> [Ptr NativeCell]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Word64
grp Map Word64 [Ptr NativeCell]
m
       in case Ptr NativeCell -> [(Ptr NativeCell, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ptr NativeCell
first ([Ptr NativeCell] -> [Int] -> [(Ptr NativeCell, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ptr NativeCell]
seen [Int
1 :: Int ..]) of
            Just Int
1 -> (Map Word64 [Ptr NativeCell]
m, [Char]
"")
            Just Int
n -> (Map Word64 [Ptr NativeCell]
m, [Char]
"_v" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
            Maybe Int
Nothing -> (Word64
-> [Ptr NativeCell]
-> Map Word64 [Ptr NativeCell]
-> Map Word64 [Ptr NativeCell]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Word64
grp ([Ptr NativeCell]
seen [Ptr NativeCell] -> [Ptr NativeCell] -> [Ptr NativeCell]
forall a. [a] -> [a] -> [a]
++ [Ptr NativeCell
first]) Map Word64 [Ptr NativeCell]
m, if [Ptr NativeCell] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ptr NativeCell]
seen then [Char]
"" else [Char]
"_v" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Ptr NativeCell] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ptr NativeCell]
seen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  pure (((Word64, Int, Int, MSection, Ptr NativeCell) -> Unit)
-> [(Word64, Int, Int, MSection, Ptr NativeCell)] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
-> Bool -> (Word64, Int, Int, MSection, Ptr NativeCell) -> Unit
unit [Char]
suffix Bool
False) [(Word64, Int, Int, MSection, Ptr NativeCell)]
now, ((Word64, Int, Int, MSection, Ptr NativeCell) -> Unit)
-> [(Word64, Int, Int, MSection, Ptr NativeCell)] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
-> Bool -> (Word64, Int, Int, MSection, Ptr NativeCell) -> Unit
unit [Char]
suffix Bool
True) [(Word64, Int, Int, MSection, Ptr NativeCell)]
later)
  where
    letCells :: Set (Ptr NativeCell)
letCells = [Ptr NativeCell] -> Set (Ptr NativeCell)
forall a. Ord a => [a] -> Set a
Set.fromList [Ptr NativeCell
c | Comb (LamI Int
_ Int
_ MSection
s Ptr NativeCell
_) <- ((Word64, GComb Val (RComb Val)) -> GComb Val (RComb Val))
-> [(Word64, GComb Val (RComb Val))] -> [GComb Val (RComb Val)]
forall a b. (a -> b) -> [a] -> [b]
map (Word64, GComb Val (RComb Val)) -> GComb Val (RComb Val)
forall a b. (a, b) -> b
snd (MCombs -> [(Word64, GComb Val (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList MCombs
combs), Ptr NativeCell
c <- MSection -> [Ptr NativeCell]
letCellsOf MSection
s, Ptr NativeCell
c Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr NativeCell
noNativeCell]
    candidates :: [(Word64, Int, Int, MSection, Ptr NativeCell)]
candidates = [(Word64, Int, Int, MSection, Ptr NativeCell)
c | c :: (Word64, Int, Int, MSection, Ptr NativeCell)
c@(Word64
i, Int
_, Int
_, MSection
_, Ptr NativeCell
cell) <- [(Word64, Int, Int, MSection, Ptr NativeCell)]
every, Word64 -> Bool
forall {a}. (Bits a, Num a) => a -> Bool
isEntry Word64
i Bool -> Bool -> Bool
|| Ptr NativeCell -> Set (Ptr NativeCell) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ptr NativeCell
cell Set (Ptr NativeCell)
letCells]
    every :: [(Word64, Int, Int, MSection, Ptr NativeCell)]
every = [(Word64
i, Int
a, Int
f, MSection
entry, Ptr NativeCell
cell) | (Word64
i, Comb (LamI Int
a Int
f MSection
entry Ptr NativeCell
cell)) <- MCombs -> [(Word64, GComb Val (RComb Val))]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList MCombs
combs, Ptr NativeCell
cell Ptr NativeCell -> Ptr NativeCell -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr NativeCell
noNativeCell]
    isEntry :: a -> Bool
isEntry a
i = a
i a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFFFF a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
    now :: [(Word64, Int, Int, MSection, Ptr NativeCell)]
now = [(Word64, Int, Int, MSection, Ptr NativeCell)
c | c :: (Word64, Int, Int, MSection, Ptr NativeCell)
c@(Word64
i, Int
_, Int
_, MSection
_, Ptr NativeCell
_) <- [(Word64, Int, Int, MSection, Ptr NativeCell)]
candidates, Word64 -> Bool
forall {a}. (Bits a, Num a) => a -> Bool
isEntry Word64
i Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
lazy]
    later :: [(Word64, Int, Int, MSection, Ptr NativeCell)]
later = [(Word64, Int, Int, MSection, Ptr NativeCell)
c | c :: (Word64, Int, Int, MSection, Ptr NativeCell)
c@(Word64
i, Int
_, Int
_, MSection
_, Ptr NativeCell
_) <- [(Word64, Int, Int, MSection, Ptr NativeCell)]
candidates, Bool -> Bool
not (Word64 -> Bool
forall {a}. (Bits a, Num a) => a -> Bool
isEntry Word64
i), Bool
lazy]
    unit :: [Char]
-> Bool -> (Word64, Int, Int, MSection, Ptr NativeCell) -> Unit
unit [Char]
suffix Bool
onDemand (Word64
i, Int
a, Int
f, MSection
entry, Ptr NativeCell
cell) =
      let name :: [Char]
name = [Char]
"u" [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]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
suffix
          cix :: CombIx
cix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
ref Word64
grp Word64
i
          describe :: [Char]
describe =
            [Char]
"; "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = "
              [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]
"\n;   arity "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
a
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", frame size "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
f
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"; " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [[Char]]
lines (Int -> MSection -> [Char] -> [Char]
forall comb. Show comb => Int -> GSection comb -> [Char] -> [Char]
prettySection Int
4 MSection
entry [Char]
"")))
          worker :: Maybe Int
worker = if Word64 -> Bool
forall {a}. (Bits a, Num a) => a -> Bool
isEntry Word64
i Bool -> Bool -> Bool
&& MSection -> Bool
CG.workerShape MSection
entry then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
a else Maybe Int
forall a. Maybe a
Nothing
       in [Char]
-> [Char]
-> Ptr NativeCell
-> MCombs
-> MSection
-> [Char]
-> Bool
-> Maybe Int
-> Bool
-> Bool
-> ([Char] -> Env -> Either [Char] Function)
-> Unit
Unit [Char]
name [Char]
name Ptr NativeCell
cell MCombs
combs MSection
entry [Char]
describe Bool
onDemand Maybe Int
worker Bool
False Bool
sandbox (\[Char]
sym Env
env -> (Text -> [Char]) -> Either Text Function -> Either [Char] Function
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
UT.unpack (Env
-> Text
-> CombIx
-> Int
-> Int
-> MSection
-> Ptr NativeCell
-> Either Text Function
genFunction Env
env ([Char] -> Text
UT.pack [Char]
sym) CombIx
cix Int
a Int
f MSection
entry Ptr NativeCell
cell))

-- | Private copies of a compiled group's entry point and local functions,
-- for a module that calls them (see 'uCopy'). The group's re-entry points
-- are not the copy's business: the Lets' cells belong to the group and
-- were dealt with when it was compiled.
copyUnits :: Compiler -> Bool -> Reference -> Word64 -> MCombs -> IO [Unit]
copyUnits :: Compiler -> Bool -> Reference -> Word64 -> MCombs -> IO [Unit]
copyUnits Compiler
c Bool
sandbox Reference
ref Word64
grp MCombs
combs = do
  Int
n <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef Int
cCopyCounter Compiler
c) (\Int
k -> (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
k))
  ([Unit]
now, [Unit]
_) <- Compiler
-> Bool
-> Bool
-> Reference
-> Word64
-> MCombs
-> IO ([Unit], [Unit])
groupUnits Compiler
c Bool
sandbox Bool
True Reference
ref Word64
grp MCombs
combs
  let copy :: Unit -> Unit
copy Unit
u =
        Unit
u
          { uName = uName u ++ "_c" ++ show n,
            uRoot = uName u ++ "_c" ++ show n,
            uCopy = True,
            uDescribe = "; private copy of " ++ uName u ++ "\n" ++ uDescribe u
          }
  [Unit] -> IO [Unit]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Unit -> Unit) -> [Unit] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map Unit -> Unit
copy [Unit]
now)

-- | The unit for a re-entry function its parent left for later.
deferredUnit :: Unit -> Deferred -> Unit
deferredUnit :: Unit -> Deferred -> Unit
deferredUnit Unit
parent Deferred
d =
  [Char]
-> [Char]
-> Ptr NativeCell
-> MCombs
-> MSection
-> [Char]
-> Bool
-> Maybe Int
-> Bool
-> Bool
-> ([Char] -> Env -> Either [Char] Function)
-> Unit
Unit
    (Text -> [Char]
UT.unpack (Deferred -> Text
dName Deferred
d))
    (Unit -> [Char]
uRoot Unit
parent)
    (Deferred -> Ptr NativeCell
dCell Deferred
d)
    (Unit -> MCombs
uCombs Unit
parent)
    (Deferred -> MSection
dBody Deferred
d)
    ( [Char]
"; "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
UT.unpack (Deferred -> Text
dName Deferred
d)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = re-entry into "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CombIx -> [Char]
forall a. Show a => a -> [Char]
show (Deferred -> CombIx
dCix Deferred
d)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at depth "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Deferred -> Int
dLoaded Deferred
d)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", frame base "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Deferred -> Int
dBase Deferred
d)
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"; " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [[Char]]
lines (Int -> MSection -> [Char] -> [Char]
forall comb. Show comb => Int -> GSection comb -> [Char] -> [Char]
prettySection Int
4 (Deferred -> MSection
dBody Deferred
d) [Char]
"")))
    )
    Bool
True
    Maybe Int
forall a. Maybe a
Nothing
    Bool
False
    (Unit -> Bool
uSandboxed Unit
parent)
    (\[Char]
_ Env
env -> (Text -> [Char]) -> Either Text Function -> Either [Char] Function
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Char]
UT.unpack (Env -> Deferred -> Either Text Function
genDeferred Env
env Deferred
d))

-- | Compiles some units as one module and installs the code in their
-- cells. Units that aren't worth compiling (see JIT.Estimate) or that the
-- code generator can't handle are left interpreted, and are not asked for
-- again: a cell's count reaches zero once. When @lazy@, the re-entry
-- functions that are only needed when something exits are not generated:
-- they become pending units (see 'pending').
compileUnits :: Compiler -> JITState -> EC.EnumMap Word64 Reference -> String -> Bool -> [Unit] -> IO ()
compileUnits :: Compiler
-> JITState
-> EnumMap Word64 Reference
-> [Char]
-> Bool
-> [Unit]
-> IO ()
compileUnits Compiler
c JITState
st EnumMap Word64 Reference
numbers [Char]
modName Bool
lazy [Unit]
candidates = do
  let config :: Config
config = Compiler -> Config
cConfig Compiler
c
  Word64
t0 <- IO Word64
getMonotonicTimeNSec
  [(Unit, (Bool, Maybe Estimate))]
judged <- [Unit]
-> (Unit -> IO (Unit, (Bool, Maybe Estimate)))
-> IO [(Unit, (Bool, Maybe Estimate))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Unit]
candidates ((Unit -> IO (Unit, (Bool, Maybe Estimate)))
 -> IO [(Unit, (Bool, Maybe Estimate))])
-> (Unit -> IO (Unit, (Bool, Maybe Estimate)))
-> IO [(Unit, (Bool, Maybe Estimate))]
forall a b. (a -> b) -> a -> b
$ \Unit
u -> (,) Unit
u ((Bool, Maybe Estimate) -> (Unit, (Bool, Maybe Estimate)))
-> IO (Bool, Maybe Estimate) -> IO (Unit, (Bool, Maybe Estimate))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Ptr NativeCell -> MSection -> IO (Bool, Maybe Estimate)
judge Config
config (Unit -> Ptr NativeCell
uCell Unit
u) (Unit -> MSection
uSection Unit
u)
  let units :: [Unit]
units = [Unit
u | (Unit
u, (Bool
True, Maybe Estimate
_)) <- [(Unit, (Bool, Maybe Estimate))]
judged]
      notWorthIt :: [(Unit, [Char])]
notWorthIt =
        [ (Unit
u, [Char]
"left interpreted: an average path takes " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Estimate -> [Char]
showEstimate Estimate
e)
        | (Unit
u, (Bool
False, Just Estimate
e)) <- [(Unit, (Bool, Maybe Estimate))]
judged
        ]
      showEstimate :: Estimate -> [Char]
showEstimate (Estimate Double
saving Double
exits Bool
_) =
        Double -> [Char]
forall {a}. RealFrac a => a -> [Char]
show2 Double
exits [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" exits and saves " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
forall {a}. RealFrac a => a -> [Char]
show2 Double
saving [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" instructions' overhead"
      show2 :: a -> [Char]
show2 a
x = Double -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
100) :: Int) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100 :: Double)
  [(Unit, [Char])] -> ((Unit, [Char]) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Unit, [Char])]
notWorthIt (((Unit, [Char]) -> IO ()) -> IO ())
-> ((Unit, [Char]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Unit
u, [Char]
why) -> Config -> [Char] -> IO ()
jitLog Config
config (Unit -> [Char]
uName Unit
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
why)
  IORef CompileTotals
-> (CompileTotals -> (CompileTotals, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef CompileTotals
cTotals Compiler
c) (\CompileTotals
t -> (CompileTotals
t {ctNotWorthIt = ctNotWorthIt t + length notWorthIt}, ()))
  Config -> [Char] -> IO ()
jitLog Config
config ([Char]
modName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": compiling " [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]
uName [Unit]
units))
  Map PoolKey Int
poolIxs <- Pool -> [PoolKey] -> IO (Map PoolKey Int)
poolIndices (Compiler -> Pool
cPool Compiler
c) ((Unit -> [PoolKey]) -> [Unit] -> [PoolKey]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (MSection -> [PoolKey]
poolKeysOf (MSection -> [PoolKey]) -> (Unit -> MSection) -> Unit -> [PoolKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> MSection
uSection) [Unit]
units)
  Map [Char] AuxMemo
memos <- IORef (Map [Char] AuxMemo) -> IO (Map [Char] AuxMemo)
forall a. IORef a -> IO a
readIORef (Compiler -> IORef (Map [Char] AuxMemo)
cRootMemos Compiler
c)
  let gen :: Unit -> Env -> Either [Char] Function
gen Unit
u Env
e = Unit -> [Char] -> Env -> Either [Char] Function
uGen Unit
u (Unit -> [Char]
uName Unit
u) Env
e
      typeNumbers :: Map Reference Word64
typeNumbers = [(Reference, Word64)] -> Map Reference Word64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Reference
r, Word64
n) | (Word64
n, Reference
r) <- EnumMap Word64 Reference -> [(Word64, Reference)]
forall k a. EnumKey k => EnumMap k a -> [(k, a)]
EC.mapToList EnumMap Word64 Reference
numbers]
      disabledD :: Deque Text
disabledD = [Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
UT.pack (Config -> [[Char]]
disabled Config
config))
      -- a private copy gets internal linkage, so that LLVM drops it once it
      -- is inlined at every call
      env :: Map (Ptr NativeCell) Text
-> Map (Ptr NativeCell) (Pair Text Int)
-> Unit
-> (Int, Int, Cells)
-> Env
env Map (Ptr NativeCell) Text
local Map (Ptr NativeCell) (Pair Text Int)
workers Unit
u (Int
base, Int
fbase, Cells
cells) =
        Layouts
-> CtxOffsets
-> Int
-> Int
-> Bool
-> Bool
-> Bool
-> MCombs
-> Map PoolKey Int
-> RtsFacts
-> Map Reference Word64
-> Cells
-> Deque Text
-> Bool
-> AuxMemo
-> Map (Ptr NativeCell) Text
-> Map (Ptr NativeCell) (Pair Text Int)
-> Bool
-> Bool
-> Switches
-> Int
-> Env
CG.Env (JITState -> Layouts
jsLayouts JITState
st) (JITState -> CtxOffsets
jsCtx JITState
st) Int
base Int
fbase (Config -> Int
stressPoll Config
config Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Config -> Int
stressCallee Config
config Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Config -> Bool
exitCall Config
config) (Unit -> MCombs
uCombs Unit
u) Map PoolKey Int
poolIxs (JITState -> RtsFacts
jsRts JITState
st) Map Reference Word64
typeNumbers Cells
cells Deque Text
disabledD Bool
lazy (AuxMemo -> [Char] -> Map [Char] AuxMemo -> AuxMemo
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault AuxMemo
forall k a. Map k a
Map.empty (Unit -> [Char]
uRoot Unit
u) Map [Char] AuxMemo
memos) Map (Ptr NativeCell) Text
local Map (Ptr NativeCell) (Pair Text Int)
workers (Unit -> Bool
uSandboxed Unit
u) (Unit -> Bool
uCopy Unit
u) (Config -> Switches
CG.switches Config
config) (Pool -> Int
poolStableSize (Compiler -> Pool
cPool Compiler
c))
      -- The functions that get a worker: calls to them from this module
      -- pass arguments and results in registers (design.md, "Workers").
      workersOf :: [Unit] -> Map (Ptr NativeCell) (Pair Text Int)
workersOf [Unit]
us
        | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([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) [[Char]
"direct", [Char]
"worker"] = Map (Ptr NativeCell) (Pair Text Int)
forall k a. Map k a
Map.empty
        | Bool
otherwise = [(Ptr NativeCell, Pair Text Int)]
-> Map (Ptr NativeCell) (Pair Text Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Unit -> Ptr NativeCell
uCell Unit
u, Text -> Int -> Pair Text Int
forall a b. a -> b -> Pair a b
Pair ([Char] -> Text
UT.pack (Unit -> [Char]
uName Unit
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_w")) Int
a) | Unit
u <- [Unit]
us, Just Int
a <- [Unit -> Maybe Int
uWorker Unit
u]]
      -- first pass: find out which functions compile, and how many exits,
      -- frames and cells for auxiliary functions each needs
      -- A function that fails as a worker (it turns out to return other
      -- than one value) is generated in the uniform form instead.
      candidates1 :: Map (Ptr NativeCell) (Pair Text Int)
candidates1 = [Unit] -> Map (Ptr NativeCell) (Pair Text Int)
workersOf [Unit]
units
      firstTry :: Unit -> Either [Char] Function
firstTry Unit
u = Unit -> Env -> Either [Char] Function
gen Unit
u (Map (Ptr NativeCell) Text
-> Map (Ptr NativeCell) (Pair Text Int)
-> Unit
-> (Int, Int, Cells)
-> Env
env Map (Ptr NativeCell) Text
forall k a. Map k a
Map.empty Map (Ptr NativeCell) (Pair Text Int)
candidates1 Unit
u (Int
0, Int
0, Cells
CG.Counting))
      firstPass :: [(Unit, Either [Char] Function)]
firstPass =
        [ case Unit -> Either [Char] Function
firstTry Unit
u of
            Left [Char]
_ | Ptr NativeCell -> Map (Ptr NativeCell) (Pair Text Int) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Unit -> Ptr NativeCell
uCell Unit
u) Map (Ptr NativeCell) (Pair Text Int)
candidates1 -> (Unit
u {uWorker = Nothing}, Unit -> Env -> Either [Char] Function
gen Unit
u (Map (Ptr NativeCell) Text
-> Map (Ptr NativeCell) (Pair Text Int)
-> Unit
-> (Int, Int, Cells)
-> Env
env Map (Ptr NativeCell) Text
forall k a. Map k a
Map.empty (Ptr NativeCell
-> Map (Ptr NativeCell) (Pair Text Int)
-> Map (Ptr NativeCell) (Pair Text Int)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Unit -> Ptr NativeCell
uCell Unit
u) Map (Ptr NativeCell) (Pair Text Int)
candidates1) Unit
u (Int
0, Int
0, Cells
CG.Counting)))
            Either [Char] Function
r -> (Unit
u, Either [Char] Function
r)
        | Unit
u <- [Unit]
units
        ]
      failed :: [(Unit, [Char])]
failed = [(Unit
u, [Char]
"not compiled: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
why) | (Unit
u, Left [Char]
why) <- [(Unit, Either [Char] Function)]
firstPass]
      skipped :: [(Unit, [Char])]
skipped = [(Unit, [Char])]
notWorthIt [(Unit, [Char])] -> [(Unit, [Char])] -> [(Unit, [Char])]
forall a. [a] -> [a] -> [a]
++ [(Unit, [Char])]
failed
      ok :: [(Unit, Function)]
ok = [(Unit
u, Function
f) | (Unit
u, Right Function
f) <- [(Unit, Either [Char] Function)]
firstPass]
  [(Unit, [Char])] -> ((Unit, [Char]) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Unit, [Char])]
failed (((Unit, [Char]) -> IO ()) -> IO ())
-> ((Unit, [Char]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Unit
u, [Char]
why) -> Config -> [Char] -> IO ()
jitLog Config
config (Unit -> [Char]
uName Unit
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
why)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Unit, Function)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Unit, Function)]
ok) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let counts :: [Int]
counts = ((Unit, Function) -> Int) -> [(Unit, Function)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Deque Exit -> Int
forall a. Deque a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Deque Exit -> Int)
-> ((Unit, Function) -> Deque Exit) -> (Unit, Function) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Exit
fnExits (Function -> Deque Exit)
-> ((Unit, Function) -> Function) -> (Unit, Function) -> Deque Exit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unit, Function) -> Function
forall a b. (a, b) -> b
snd) [(Unit, Function)]
ok
        fcounts :: [Int]
fcounts = ((Unit, Function) -> Int) -> [(Unit, Function)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Deque Frame -> Int
forall a. Deque a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Deque Frame -> Int)
-> ((Unit, Function) -> Deque Frame) -> (Unit, Function) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Frame
fnFrames (Function -> Deque Frame)
-> ((Unit, Function) -> Function)
-> (Unit, Function)
-> Deque Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unit, Function) -> Function
forall a b. (a, b) -> b
snd) [(Unit, Function)]
ok
        acounts :: [Int]
acounts = ((Unit, Function) -> Int) -> [(Unit, Function)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Unit
_, Function
f) -> Deque (Pair Text (Ptr NativeCell)) -> Int
forall a. Deque a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Function -> Deque (Pair Text (Ptr NativeCell))
fnAux Function
f) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Deque Deferred -> Int
forall a. Deque a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Function -> Deque Deferred
fnDeferred Function
f)) [(Unit, Function)]
ok
    Int
base <- Exits -> [Exit] -> IO Int
registerExits (Compiler -> Exits
cExits Compiler
c) (((Unit, Function) -> [Exit]) -> [(Unit, Function)] -> [Exit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Deque Exit -> [Exit]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Deque Exit -> [Exit])
-> ((Unit, Function) -> Deque Exit) -> (Unit, Function) -> [Exit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Exit
fnExits (Function -> Deque Exit)
-> ((Unit, Function) -> Function) -> (Unit, Function) -> Deque Exit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unit, Function) -> Function
forall a b. (a, b) -> b
snd) [(Unit, Function)]
ok)
    Int
fbase <- Frames -> [Frame] -> IO Int
registerFrames (Compiler -> Frames
cFrames Compiler
c) (((Unit, Function) -> [Frame]) -> [(Unit, Function)] -> [Frame]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Deque Frame -> [Frame]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Deque Frame -> [Frame])
-> ((Unit, Function) -> Deque Frame) -> (Unit, Function) -> [Frame]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Frame
fnFrames (Function -> Deque Frame)
-> ((Unit, Function) -> Function)
-> (Unit, Function)
-> Deque Frame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unit, Function) -> Function
forall a b. (a, b) -> b
snd) [(Unit, Function)]
ok)
    Ptr NativeCell
cellBlock <- Int -> IO (Ptr NativeCell)
newNativeCells ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
acounts)
    -- second pass, with each function's real exit and frame bases and cells
    let cells :: [Cells]
cells = [Deque (Ptr NativeCell) -> Cells
CG.Cells ([Ptr NativeCell] -> Deque (Ptr NativeCell)
forall a. [a] -> Deque a
D.fromList ((Int -> Ptr NativeCell) -> [Int] -> [Ptr NativeCell]
forall a b. (a -> b) -> [a] -> [b]
map (Ptr NativeCell -> Int -> Ptr NativeCell
nativeCellAt Ptr NativeCell
cellBlock) [Int
a .. Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])) | (Int
a, Int
n) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 [Int]
acounts) [Int]
acounts]
        bases :: [(Int, Int, Cells)]
bases = [Int] -> [Int] -> [Cells] -> [(Int, Int, Cells)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
base [Int]
counts) ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
fbase [Int]
fcounts) [Cells]
cells
        -- calls between the functions of this module are direct (a call
        -- site has the same exits either way, so the counts above hold)
        local :: Map (Ptr NativeCell) Text
local
          | [Char]
"direct" [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 = Map (Ptr NativeCell) Text
forall k a. Map k a
Map.empty
          | Bool
otherwise = [(Ptr NativeCell, Text)] -> Map (Ptr NativeCell) Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Unit -> Ptr NativeCell
uCell Unit
u, [Char] -> Text
UT.pack (Unit -> [Char]
uName Unit
u)) | (Unit
u, Function
_) <- [(Unit, Function)]
ok]
        compiled :: [(Unit, Function)]
compiled = [(Unit
u, Function
f) | ((Int, Int, Cells)
b, (Unit
u, Function
_)) <- [(Int, Int, Cells)]
-> [(Unit, Function)] -> [((Int, Int, Cells), (Unit, Function))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int, Cells)]
bases [(Unit, Function)]
ok, Right Function
f <- [Unit -> Env -> Either [Char] Function
gen Unit
u (Map (Ptr NativeCell) Text
-> Map (Ptr NativeCell) (Pair Text Int)
-> Unit
-> (Int, Int, Cells)
-> Env
env Map (Ptr NativeCell) Text
local ([Unit] -> Map (Ptr NativeCell) (Pair Text Int)
workersOf (((Unit, Function) -> Unit) -> [(Unit, Function)] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map (Unit, Function) -> Unit
forall a b. (a, b) -> a
fst [(Unit, Function)]
ok)) Unit
u (Int, Int, Cells)
b)]]
        fns :: [Function]
fns = ((Unit, Function) -> Function) -> [(Unit, Function)] -> [Function]
forall a b. (a -> b) -> [a] -> [b]
map (Unit, Function) -> Function
forall a b. (a, b) -> b
snd [(Unit, Function)]
compiled
        ir :: Text
ir = Text
modulePrelude Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Deque Text -> Text
unlinesT ([Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ((Function -> Text) -> [Function] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Function -> Text
fnIR [Function]
fns))
    -- the second pass's exits and frames name the auxiliary functions' cells
    Exits -> Int -> [Exit] -> IO ()
replaceExits (Compiler -> Exits
cExits Compiler
c) Int
base ((Function -> [Exit]) -> [Function] -> [Exit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Deque Exit -> [Exit]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Deque Exit -> [Exit])
-> (Function -> Deque Exit) -> Function -> [Exit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Exit
fnExits) [Function]
fns)
    Frames -> Int -> [Frame] -> IO ()
replaceFrames (Compiler -> Frames
cFrames Compiler
c) Int
fbase ((Function -> [Frame]) -> [Function] -> [Frame]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Deque Frame -> [Frame]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Deque Frame -> [Frame])
-> (Function -> Deque Frame) -> Function -> [Frame]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Frame
fnFrames) [Function]
fns)
    -- The dump has each function's MCode as a comment above its IR, and
    -- says which units were not compiled and why.
    Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Config -> Maybe [Char]
dumpIR Config
config) (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
      let annotated :: Text
annotated =
            Deque Text -> Text
unlinesT (Deque Text -> Text) -> ([Text] -> Deque Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Deque Text
forall a. [a] -> Deque a
D.fromList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
              ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
                [Char] -> Text
UT.pack
                ( [ [Char]
"; module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
modName,
                    [Char]
"; " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([(Unit, Function)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Unit, Function)]
compiled) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of " [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]
candidates) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" functions compiled"
                  ]
                    [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"; " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Unit -> [Char]
uName Unit
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
why | (Unit
u, [Char]
why) <- [(Unit, [Char])]
skipped]
                )
                [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
modulePrelude]
                [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char] -> Text
UT.pack (Unit -> [Char]
uDescribe Unit
u), Function -> Text
fnIR Function
f] | (Unit
u, Function
f) <- [(Unit, Function)]
compiled]
      if [Char] -> Bool
forall {t :: * -> *} {a}.
(Eq (t a), IsString (t a), Foldable t) =>
t a -> Bool
dumpToStderr [Char]
dir
        then [Char] -> IO ()
jitDump (Text -> [Char]
UT.unpack Text
annotated)
        else do
          Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
dir
          [Char] -> Text -> IO ()
TIO.writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
modName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".ll") (Text -> Text
UT.toText Text
annotated)
    Word64
tGen <- IO Word64
getMonotonicTimeNSec
    Either [Char] (Maybe [Char])
r <- Bool -> [Char] -> Text -> IO (Either [Char] (Maybe [Char]))
addModule (Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Config -> Maybe [Char]
dumpIR Config
config)) (Config -> [Char]
passes Config
config) (Text -> Text
UT.toText Text
ir)
    Word64
tOpt <- IO Word64
getMonotonicTimeNSec
    case Either [Char] (Maybe [Char])
r of
      -- a module that doesn't compile or link is a bug in the generator: say so even without the log
      Left [Char]
e -> Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"[jit] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
modName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e)
      Right Maybe [Char]
optimized -> do
        -- the module after the passes: what actually runs
        Maybe ([Char], [Char]) -> (([Char], [Char]) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((,) ([Char] -> [Char] -> ([Char], [Char]))
-> Maybe [Char] -> Maybe ([Char] -> ([Char], [Char]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Maybe [Char]
dumpIR Config
config Maybe ([Char] -> ([Char], [Char]))
-> Maybe [Char] -> Maybe ([Char], [Char])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [Char]
optimized) ((([Char], [Char]) -> IO ()) -> IO ())
-> (([Char], [Char]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
dir, [Char]
txt) ->
          if [Char] -> Bool
forall {t :: * -> *} {a}.
(Eq (t a), IsString (t a), Foldable t) =>
t a -> Bool
dumpToStderr [Char]
dir
            then [Char] -> IO ()
jitDump ([Char]
"; module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
modName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" after the passes\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
txt)
            else [Char] -> [Char] -> IO ()
writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
modName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".opt.ll") [Char]
txt
        -- The re-entry functions left for later become pending before any
        -- code that can exit to them is installed, so that no request for
        -- one is ever made before it is known here.
        [(Unit, Function)] -> ((Unit, Function) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Unit, Function)]
compiled (((Unit, Function) -> IO ()) -> IO ())
-> ((Unit, Function) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Unit
u, Function
f) -> do
          -- forced: a lazy union here would keep the whole Function, IR text
          -- included, alive for the rest of the run (found as 3.6 GB of
          -- String in an eager run of the test transcript, 2026-10-04)
          let !memo :: AuxMemo
memo = Function -> AuxMemo
fnMemo Function
f
          IORef (Map [Char] AuxMemo)
-> (Map [Char] AuxMemo -> (Map [Char] AuxMemo, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef (Map [Char] AuxMemo)
cRootMemos Compiler
c) (\Map [Char] AuxMemo
m -> let !m' :: Map [Char] AuxMemo
m' = (AuxMemo -> AuxMemo -> AuxMemo)
-> [Char] -> AuxMemo -> Map [Char] AuxMemo -> Map [Char] AuxMemo
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MapS.insertWith AuxMemo -> AuxMemo -> AuxMemo
forall k a. Ord k => Map k a -> Map k a -> Map k a
MapS.union (Unit -> [Char]
uRoot Unit
u) AuxMemo
memo Map [Char] AuxMemo
m in (Map [Char] AuxMemo
m', ()))
          Deque Deferred -> (Deferred -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Function -> Deque Deferred
fnDeferred Function
f) (Compiler -> Unit -> IO ()
addPending Compiler
c (Unit -> IO ()) -> (Deferred -> Unit) -> Deferred -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> Deferred -> Unit
deferredUnit Unit
u)
        let described :: [([Char], [Char])]
described = [(Unit -> [Char]
uName Unit
u, (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
2 ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') (Unit -> [Char]
uDescribe Unit
u)))) | (Unit
u, Function
_) <- [(Unit, Function)]
compiled]
        -- the first lookup compiles the module; time it apart from the installs
        Word64
tCode <- case [(Unit, Function)]
compiled of
          (Unit
u, Function
f) : [(Unit, Function)]
_ | Bool -> Bool
not (Unit -> Bool
uCopy Unit
u) -> [Char] -> IO (Either [Char] (FunPtr (ZonkAny 0)))
forall a. [Char] -> IO (Either [Char] (FunPtr a))
lookupSymbol (Text -> [Char]
UT.unpack (Function -> Text
fnName Function
f)) IO (Either [Char] (FunPtr (ZonkAny 0))) -> IO Word64 -> IO Word64
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Word64
getMonotonicTimeNSec
          [(Unit, Function)]
_ -> IO Word64
getMonotonicTimeNSec
        [(Unit, Function)] -> ((Unit, Function) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Unit, Function)]
compiled (((Unit, Function) -> IO ()) -> IO ())
-> ((Unit, Function) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Unit
u, Function
f) -> do
          Deque Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Function -> Deque Text
fnNotes Function
f) ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
note -> Config -> [Char] -> IO ()
jitLog Config
config (Text -> [Char]
UT.unpack (Function -> Text
fnName Function
f) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": partly interpreted: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
UT.unpack Text
note)
          [([Char], Ptr NativeCell)]
-> (([Char], Ptr NativeCell) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((if Unit -> Bool
uCopy Unit
u then [] else [(Text -> [Char]
UT.unpack (Function -> Text
fnName Function
f), Function -> Ptr NativeCell
fnCell Function
f)]) [([Char], Ptr NativeCell)]
-> [([Char], Ptr NativeCell)] -> [([Char], Ptr NativeCell)]
forall a. [a] -> [a] -> [a]
++ [(Text -> [Char]
UT.unpack Text
sym, Ptr NativeCell
cell) | Pair Text
sym Ptr NativeCell
cell <- Deque (Pair Text (Ptr NativeCell)) -> [Pair Text (Ptr NativeCell)]
forall a. Deque a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Function -> Deque (Pair Text (Ptr NativeCell))
fnAux Function
f)]) ((([Char], Ptr NativeCell) -> IO ()) -> IO ())
-> (([Char], Ptr NativeCell) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
sym, Ptr NativeCell
cell) ->
            [Char] -> IO (Either [Char] (FunPtr (ZonkAny 1)))
forall a. [Char] -> IO (Either [Char] (FunPtr a))
lookupSymbol [Char]
sym IO (Either [Char] (FunPtr (ZonkAny 1)))
-> (Either [Char] (FunPtr (ZonkAny 1)) -> 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 [Char]
e -> Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"[jit] " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sym [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" could not be linked: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e)
              Right FunPtr (ZonkAny 1)
fp -> do
                -- stress mode install=N: a module's functions appear one at a time
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Int
stressInstall Config
config Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Int -> IO ()
threadDelay (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Config -> Int
stressInstall Config
config))
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
stats Config
config) (Exits -> Ptr (ZonkAny 2) -> [Char] -> IO ()
forall a. Exits -> Ptr a -> [Char] -> IO ()
nameEntry (Compiler -> Exits
cExits Compiler
c) (FunPtr (ZonkAny 1) -> Ptr (ZonkAny 2)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (ZonkAny 1)
fp) ([Char]
sym [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
sym [([Char], [Char])]
described)))
                Ptr NativeCell -> Ptr () -> IO ()
writeNativeCode Ptr NativeCell
cell (FunPtr (ZonkAny 1) -> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (ZonkAny 1)
fp)
        Word64
t1 <- IO Word64
getMonotonicTimeNSec
        let onDemand :: Int
onDemand = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Unit
u, Function
_) <- [(Unit, Function)]
compiled, Unit -> Bool
uOnDemand Unit
u]
            copies :: Int
copies = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Unit
u, Function
_) <- [(Unit, Function)]
compiled, Unit -> Bool
uCopy Unit
u]
        IORef CompileTotals
-> (CompileTotals -> (CompileTotals, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (Compiler -> IORef CompileTotals
cTotals Compiler
c) ((CompileTotals -> (CompileTotals, ())) -> IO ())
-> (CompileTotals -> (CompileTotals, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CompileTotals
t ->
          ( CompileTotals
t
              { ctModules = ctModules t + 1,
                ctCopies = ctCopies t + copies,
                ctFunctions = ctFunctions t + length compiled - onDemand - copies,
                ctAuxiliary = ctAuxiliary t + sum (map (length . fnAux) fns),
                ctOnDemand = ctOnDemand t + onDemand,
                ctIRBytes = ctIRBytes t + UT.size ir,
                ctNanoseconds = ctNanoseconds t + (t1 - t0),
                ctGenerate = ctGenerate t + (tGen - t0),
                ctOptimize = ctOptimize t + (tOpt - tGen),
                ctCodegen = ctCodegen t + (tCode - tOpt)
              },
            ()
          )
        Config -> [Char] -> IO ()
jitLog
          Config
config
          ( [Char]
modName
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": compiled "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([(Unit, Function)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Unit, Function)]
compiled)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of "
              [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]
candidates)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" functions"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Int
copies Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
copies [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" private copies)" else [Char]
"")
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Function -> Int) -> [Function] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Deque (Pair Text (Ptr NativeCell)) -> Int
forall a. Deque a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Deque (Pair Text (Ptr NativeCell)) -> Int)
-> (Function -> Deque (Pair Text (Ptr NativeCell)))
-> Function
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque (Pair Text (Ptr NativeCell))
fnAux) [Function]
fns))
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" auxiliary, "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Function -> Int) -> [Function] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Deque Deferred -> Int
forall a. Deque a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Deque Deferred -> Int)
-> (Function -> Deque Deferred) -> Function -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Deque Deferred
fnDeferred) [Function]
fns))
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" left for later, "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
counts)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" exits, "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
UT.size Text
ir 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, in "
              [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"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (generate "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall {a}. Integral a => a -> [Char]
ms (Word64
tGen Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
t0)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", parse and optimize "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall {a}. Integral a => a -> [Char]
ms (Word64
tOpt Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
tGen)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", code "
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall {a}. Integral a => a -> [Char]
ms (Word64
tCode Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
tOpt)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
          )
  where
    ms :: a -> [Char]
ms a
ns = Double -> [Char]
forall a. Show a => a -> [Char]
show (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
ns Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double)
    -- "-" prints the dump; so does an empty directory name, rather than
    -- writing into the current directory
    dumpToStderr :: t a -> Bool
dumpToStderr t a
dir = t a
dir t a -> t a -> Bool
forall a. Eq a => a -> a -> Bool
== t a
"-" Bool -> Bool -> Bool
|| t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
dir