tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

PortableCompiler.hs (7801B)

      1 -- Host supervision of an authenticated portable compiler, not source semantics.
      2 -- Errors are IO failures so CLI, REPL and tests choose their own presentation.
      3 module PortableCompiler
      4   ( CompilerOptions(..), validateCompilerOptions, checkPortableCompiler
      5   , buildPortableModule, buildPortableResult, portableExports
      6   ) where
      7 
      8 import ContentStore
      9 import Workspace (withWorkspace)
     10 import ContentStore.Bundle (unpackIndexedBundleToStore, indexedTreeDomain)
     11 import ContentStore.Executable
     12 import Module.Manifest
     13 import Runtime (T(..), EvaluatedForm(Decode), apply, ofString, ofNumber, toString, formatT)
     14 import IODriver (IOPermissions(..), runIO)
     15 import Paths_tricu (getDataFileName)
     16 import Crypto.Hash (Digest, SHA256, hash)
     17 import Control.Exception (IOException, catch)
     18 import Control.Monad (when, unless)
     19 import System.Directory (canonicalizePath, createDirectoryIfMissing)
     20 import System.FilePath (takeExtension, takeBaseName)
     21 import System.Timeout (timeout)
     22 import System.IO (stderr)
     23 import GHC.Clock (getMonotonicTimeNSec)
     24 import GHC.Stats
     25 import qualified Data.Text as T
     26 import qualified Data.ByteString as BS
     27 import qualified Data.ByteString.Lazy as BL
     28 import qualified Data.Aeson as JSON
     29 
     30 -- Explicit artifact selection; absence selects the packaged stable compiler.
     31 -- Tool stores are never populated by implicit source loading.
     32 data CompilerOptions = CompilerOptions
     33   { compilerManifest :: Maybe String
     34   , compilerToolStore :: Maybe FilePath
     35   , compilerSeconds :: Int
     36   , compilerProfile :: Bool
     37   } deriving (Show)
     38 
     39 -- Startup and actual compilation use the same artifact selection, validation
     40 -- and load deadline. Neither path may fall back from an explicit toolchain.
     41 checkPortableCompiler :: CompilerOptions -> StorePath -> IO ()
     42 checkPortableCompiler options store = do
     43   validateCompilerOptions options
     44   compilerDeadline options $ do
     45     _ <- loadCompiler (const $ pure ()) options store
     46     pure ()
     47 
     48 compilerDeadline :: CompilerOptions -> IO a -> IO a
     49 compilerDeadline options action = do
     50   result <- timeout (compilerSeconds options * 1000000) action
     51   maybe (fail "Portable compiler load/build deadline exceeded") pure result
     52 
     53 loadCompiler :: (String -> IO ()) -> CompilerOptions -> StorePath -> IO (String, Runtime.T)
     54 loadCompiler sample options store = do
     55   let tools = maybe store StorePath (compilerToolStore options)
     56   pin <- maybe (packagedCompiler tools) (pure . T.pack) (compilerManifest options)
     57   (identity, worker) <- loadVerifiedExportWith sample tools pin "sourceBuildGraph"
     58   pure (case compilerManifest options of
     59           Nothing -> packagedCompilerSha256
     60           Just _ -> T.unpack identity, worker)
     61 
     62 -- Cabal records an installation-relative data directory. Nix-built binaries
     63 -- retain their data closure when invoked outside the checkout. An explicit
     64 -- tricu_datadir override is useful for relocatable distributions and diagnostics.
     65 packagedCompilerSha256 :: String
     66 packagedCompilerSha256 = "d70de875988dfa309f2c167992928866f88b08af351918b8c7b5d88c541c6e94"
     67 
     68 packagedCompiler :: StorePath -> IO T.Text
     69 packagedCompiler store = do
     70   path <- getDataFileName "bootstrap/build-stable.arboricx"
     71   bytes <- BS.readFile path `catch` (\(err :: IOException) ->
     72     fail $ "Packaged stable compiler unavailable at " ++ path ++ ": " ++ show err)
     73   unless (show (hash bytes :: Digest SHA256) == packagedCompilerSha256) $
     74     fail "Packaged stable compiler SHA256 mismatch; reinstall or select --toolchain explicitly"
     75   roots <- unpackIndexedBundleToStore store bytes
     76   putManifest store (ModuleManifest []
     77     [ModuleExport name (ObjectRef (unDomain indexedTreeDomain) root)
     78       "arboricx.abi.tree.v1" | (name, root) <- roots])
     79 
     80 portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Runtime.T)]
     81 portableExports options selected path = do
     82   (store, pin) <- buildPortableModule options selected path
     83   loadVerifiedExports store pin
     84 
     85 validateCompilerOptions :: CompilerOptions -> IO ()
     86 validateCompilerOptions options = do
     87   when (compilerManifest options == Nothing && compilerToolStore options /= Nothing) $
     88     fail "--tool-store requires --toolchain"
     89   unless (compilerSeconds options >= 1 && compilerSeconds options <= 86400) $
     90     fail "--compile-timeout must be between 1 and 86400 seconds"
     91 
     92 -- Workspace location preparation preserves the native flat-workspace ABI.
     93 -- All header staging, scope, compilation, publication and cache policy is tricu.
     94 buildPortableModule :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text)
     95 buildPortableModule options appStore input = do
     96   (store,manifest,_) <- buildPortableResult options appStore input
     97   pure (store,manifest)
     98 
     99 -- Keep the compiler-returned receipt available to reproduction tooling instead
    100 -- of recovering execution evidence from a mutable cache locator afterward.
    101 buildPortableResult :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text, T.Text)
    102 buildPortableResult options appStore input = do
    103   validateCompilerOptions options
    104   when (compilerProfile options) $ do
    105     enabled <- getRTSStatsEnabled
    106     unless enabled $ fail "--compile-profile requires +RTS -T"
    107   let sample label = when (compilerProfile options) (compilerSample label)
    108   sample "begin"
    109   source <- canonicalizePath input
    110   unless (takeExtension source == ".tri") $ fail "Portable compilation requires a .tri module file"
    111   store0 <- resolveStorePath appStore
    112   createDirectoryIfMissing True (unStorePath store0)
    113   root <- canonicalizePath (unStorePath store0)
    114   let store = StorePath root
    115       name = takeBaseName source
    116   built <- compilerDeadline options $ withWorkspace input $ \directory -> do
    117     (compilerIdentity, worker) <- loadCompiler sample options store
    118     let action = foldl apply worker (map ofString
    119           [directory, root, compilerIdentity, name])
    120         permissions = IOPermissions [directory, root] [root] False False
    121     -- sourceBuildGraph returns a bare v1 action; this is transport framing,
    122     -- not source compilation or a source-loaded IO adapter.
    123     let envelope = Fork (ofString "tricuIO") (Fork (ofNumber 1) action)
    124     output <- runIO permissions envelope >>= either (fail . ("Compiler IO error: " ++)) pure
    125     sample "build-returned"
    126     case output of
    127       Fork (Stem Leaf) (Fork (Fork manifest receipt) _) -> do
    128         manifestHash <- either (fail . ("Invalid compiler manifest output: " ++)) (pure . T.pack)
    129           (toString manifest)
    130         receiptHash <- either (fail . ("Invalid compiler receipt output: " ++)) (pure . T.pack)
    131           (toString receipt)
    132         _ <- loadVerifiedManifest store manifestHash
    133         either (fail . ("Invalid compiler receipt hash: " ++)) pure (textToHashBytes receiptHash)
    134         receiptBytes <- getObject store receiptHash >>= maybe (fail "Compiler receipt missing") pure
    135         unless (hashObject (Domain "arboricx.build-receipt.v1") receiptBytes == receiptHash) $
    136           fail "Compiler receipt digest mismatch"
    137         pure (manifestHash,receiptHash)
    138       Fork Leaf (Fork problem _) -> fail $ "Portable compilation failed: " ++ formatT Decode problem
    139       _ -> fail "Invalid portable compiler Result"
    140   let (manifest,receipt) = built
    141   sample "publication-verified"
    142   pure (store, manifest,receipt)
    143 
    144 -- Lightweight stage samples: no forced collection or expanded-tree traversal.
    145 -- Allocation/live counters reflect the most recent RTS collection.
    146 compilerSample :: String -> IO ()
    147 compilerSample label = do
    148   wall <- getMonotonicTimeNSec
    149   stats <- getRTSStats
    150   BL.hPutStr stderr (JSON.encode (JSON.object
    151     [ "compiler_stage" JSON..= label
    152     , "wall_ns" JSON..= wall
    153     , "allocated_bytes" JSON..= allocated_bytes stats
    154     , "live_bytes" JSON..= gcdetails_live_bytes (gc stats)
    155     , "gc_elapsed_ns" JSON..= gc_elapsed_ns stats
    156     ]))
    157   BL.hPutStr stderr "\n"
    158