tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

PortableCompiler.hs (7866B)

      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 (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   , compilerIOVersion :: Int
     38   } deriving (Show)
     39 
     40 -- Startup and actual compilation use the same artifact selection, validation
     41 -- and load deadline. Neither path may fall back from an explicit toolchain.
     42 checkPortableCompiler :: CompilerOptions -> StorePath -> IO ()
     43 checkPortableCompiler options store = do
     44   validateCompilerOptions options
     45   compilerDeadline options $ do
     46     _ <- loadCompiler (const $ pure ()) options store
     47     pure ()
     48 
     49 compilerDeadline :: CompilerOptions -> IO a -> IO a
     50 compilerDeadline options action = do
     51   result <- timeout (compilerSeconds options * 1000000) action
     52   maybe (fail "Portable compiler load/build deadline exceeded") pure result
     53 
     54 loadCompiler :: (String -> IO ()) -> CompilerOptions -> StorePath -> IO (String, Runtime.T)
     55 loadCompiler sample options store = do
     56   let tools = maybe store StorePath (compilerToolStore options)
     57   pin <- maybe (packagedCompiler tools) (pure . T.pack) (compilerManifest options)
     58   (identity, worker) <- loadVerifiedExportWith sample tools pin "sourceBuildGraph"
     59   pure (case compilerManifest options of
     60           Nothing -> packagedCompilerSha256
     61           Just _ -> T.unpack identity, worker)
     62 
     63 -- Cabal records an installation-relative data directory. Nix-built binaries
     64 -- retain their data closure when invoked outside the checkout. An explicit
     65 -- tricu_datadir override is useful for relocatable distributions and diagnostics.
     66 packagedCompilerSha256 :: String
     67 packagedCompilerSha256 = "819ad1c86fbf2d6f86533439217146eb9ffd37ca7f95bb278063a28f0ab5b534"
     68 
     69 packagedCompiler :: StorePath -> IO T.Text
     70 packagedCompiler store = do
     71   path <- getDataFileName "bootstrap/build-stable.arboricx"
     72   bytes <- BS.readFile path `catch` (\(err :: IOException) ->
     73     fail $ "Packaged stable compiler unavailable at " ++ path ++ ": " ++ show err)
     74   unless (show (hash bytes :: Digest SHA256) == packagedCompilerSha256) $
     75     fail "Packaged stable compiler SHA256 mismatch; reinstall or select --toolchain explicitly"
     76   roots <- unpackIndexedBundleToStore store bytes
     77   putManifest store (ModuleManifest []
     78     [ModuleExport name (ObjectRef (unDomain indexedTreeDomain) root)
     79       "arboricx.abi.tree.v1" | (name, root) <- roots])
     80 
     81 portableExports :: CompilerOptions -> Maybe FilePath -> FilePath -> IO [(String, Runtime.T)]
     82 portableExports options selected path = do
     83   (store, pin) <- buildPortableModule options selected path
     84   loadVerifiedExports store pin
     85 
     86 validateCompilerOptions :: CompilerOptions -> IO ()
     87 validateCompilerOptions options = do
     88   when (compilerManifest options == Nothing && compilerToolStore options /= Nothing) $
     89     fail "--tool-store requires --toolchain"
     90   unless (compilerIOVersion options == 2) $
     91     fail "--toolchain-io-version must be 2; IO v1 compilers require a retained v1 runtime"
     92   unless (compilerSeconds options >= 1 && compilerSeconds options <= 86400) $
     93     fail "--compile-timeout must be between 1 and 86400 seconds"
     94 
     95 -- Workspace location preparation preserves the native flat-workspace ABI.
     96 -- All header staging, scope, compilation, publication and cache policy is tricu.
     97 buildPortableModule :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text)
     98 buildPortableModule options appStore input = do
     99   (store,manifest,_) <- buildPortableResult options appStore input
    100   pure (store,manifest)
    101 
    102 -- Keep the compiler-returned receipt available to reproduction tooling instead
    103 -- of recovering execution evidence from a mutable cache locator afterward.
    104 buildPortableResult :: CompilerOptions -> Maybe FilePath -> FilePath -> IO (StorePath, T.Text, T.Text)
    105 buildPortableResult options appStore input = do
    106   validateCompilerOptions options
    107   when (compilerProfile options) $ do
    108     enabled <- getRTSStatsEnabled
    109     unless enabled $ fail "--compile-profile requires +RTS -T"
    110   let sample label = when (compilerProfile options) (compilerSample label)
    111   sample "begin"
    112   source <- canonicalizePath input
    113   unless (takeExtension source == ".tri") $ fail "Portable compilation requires a .tri module file"
    114   store0 <- resolveStorePath appStore
    115   createDirectoryIfMissing True (unStorePath store0)
    116   root <- canonicalizePath (unStorePath store0)
    117   let store = StorePath root
    118       name = takeBaseName source
    119   built <- compilerDeadline options $ withWorkspace input $ \directory -> do
    120     (compilerIdentity, worker) <- loadCompiler sample options store
    121     let action = foldl apply worker (map ofString
    122           [directory, root, compilerIdentity, name])
    123         version = compilerIOVersion options
    124     -- Honor the selected protocol exactly; never probe or retry an interpreter.
    125     let envelope = Fork (ofString "tricuIO") (Fork (ofNumber (toInteger version)) action)
    126     output <- runIO envelope >>= either (fail . ("Compiler IO error: " ++)) pure
    127     sample "build-returned"
    128     case output of
    129       Fork (Stem Leaf) (Fork (Fork manifest receipt) _) -> do
    130         manifestHash <- either (fail . ("Invalid compiler manifest output: " ++)) (pure . T.pack)
    131           (toString manifest)
    132         receiptHash <- either (fail . ("Invalid compiler receipt output: " ++)) (pure . T.pack)
    133           (toString receipt)
    134         _ <- loadVerifiedManifest store manifestHash
    135         either (fail . ("Invalid compiler receipt hash: " ++)) pure (textToHashBytes receiptHash)
    136         receiptBytes <- getObject store receiptHash >>= maybe (fail "Compiler receipt missing") pure
    137         unless (hashObject (Domain "arboricx.build-receipt.v1") receiptBytes == receiptHash) $
    138           fail "Compiler receipt digest mismatch"
    139         pure (manifestHash,receiptHash)
    140       Fork Leaf (Fork problem _) -> fail $ "Portable compilation failed: " ++ formatT Decode problem
    141       _ -> fail "Invalid portable compiler Result"
    142   let (manifest,receipt) = built
    143   sample "publication-verified"
    144   pure (store, manifest,receipt)
    145 
    146 -- Lightweight stage samples: no forced collection or expanded-tree traversal.
    147 -- Allocation/live counters reflect the most recent RTS collection.
    148 compilerSample :: String -> IO ()
    149 compilerSample label = do
    150   wall <- getMonotonicTimeNSec
    151   stats <- getRTSStats
    152   BL.hPutStr stderr (JSON.encode (JSON.object
    153     [ "compiler_stage" JSON..= label
    154     , "wall_ns" JSON..= wall
    155     , "allocated_bytes" JSON..= allocated_bytes stats
    156     , "live_bytes" JSON..= gcdetails_live_bytes (gc stats)
    157     , "gc_elapsed_ns" JSON..= gc_elapsed_ns stats
    158     ]))
    159   BL.hPutStr stderr "\n"
    160