tricu

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

CompilerProbe.hs (6340B)

      1 {-# LANGUAGE BangPatterns #-}
      2 {-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
      3 module CompilerProbe where
      4 import Runtime.Tree
      5 import Runtime.Value
      6 import Control.Exception (evaluate)
      7 import Control.Monad (forM_, unless)
      8 import Data.Array (Array, listArray, (!), elems)
      9 import Data.Bits ((.|.), shiftL)
     10 import qualified Data.ByteString as BS
     11 import qualified Data.Text as Text
     12 import qualified Data.Text.Encoding as Text
     13 import Data.Word (Word32)
     14 import GHC.Clock (getMonotonicTimeNSec)
     15 import GHC.Stats
     16 import System.Environment (getArgs)
     17 import System.Exit (die)
     18 import System.Mem (performGC)
     19 import Text.Printf (printf)
     20 import Text.Read (readMaybe)
     21 
     22 now :: IO Double
     23 now = (/1e9) . fromIntegral <$> getMonotonicTimeNSec
     24 utf8 :: FilePath -> IO String
     25 utf8 path = do
     26   b <- BS.readFile path
     27   either (die . show) (pure . Text.unpack) (Text.decodeUtf8' b)
     28 word :: BS.ByteString -> Int -> Int
     29 word b at = fromIntegral (foldr (.|.) 0 [fromIntegral (BS.index b (at+j)) `shiftL` (8*j) | j<-[0..3]] :: Word32)
     30 -- Bounds and backward references are checked before constructing the lazy array.
     31 load :: FilePath -> IO (T,T)
     32 load dir = do
     33   (compiler, env, _) <- loadLibrary dir
     34   pure (compiler, env)
     35 
     36 loadLibrary :: FilePath -> IO (T,T,[(String,T)])
     37 loadLibrary dir = do
     38   b <- BS.readFile (dir++"/compiler.dag")
     39   unless (BS.length b >= 8) (die "truncated DAG")
     40   let n=word b 0; root=word b 4
     41   unless (n>0 && n<=1000000 && root>=0 && root<n && BS.length b==8+9*n) (die "invalid DAG header")
     42   forM_ [0..n-1] $ \i -> do
     43     let at=8+9*i; tag=BS.index b at; l=word b (at+1); r=word b (at+5)
     44         prior x=x>=0 && x<i
     45     unless (case tag of 0->l==0 && r==0; 1->prior l && r==0; 2->prior l && prior r; _->False)
     46       (die "invalid DAG record")
     47   let trees :: Array Int T
     48       trees=listArray (0,n-1) [case BS.index b (8+9*i) of
     49         0->Leaf; 1->Stem (trees ! word b (9+9*i)); _->Fork (trees ! word b (9+9*i)) (trees ! word b (13+9*i)) | i<-[0..n-1]]
     50   -- Force every physical node and child pointer, never expand shared subtrees.
     51   forM_ (elems trees) $ \t -> evaluate (case t of Leaf->(); Stem x->x `seq` (); Fork x y->x `seq` y `seq` ())
     52   bindings <- lines <$> utf8 (dir++"/environment.tsv")
     53   env <- mapM (\line -> case words line of
     54     [name,idx] | let i=read idx, i>=0 && i<n -> do
     55       let key=ofString name
     56       _<-evaluate (force key)
     57       pure (Fork key (trees ! read idx))
     58     _ -> die "invalid environment binding") bindings
     59   let environment=ofList env
     60   _<-evaluate (forceSpine environment)
     61   exported <- lines <$> utf8 (dir++"/compiler-exports.tsv")
     62   library <- mapM (\line -> case words line of
     63     [name,idx] | Just i <- readMaybe idx, i>=0 && i<n -> pure (name,trees!i)
     64     _ -> die "invalid compiler export") exported
     65   pure (trees!root, environment, library)
     66 
     67 force :: T -> ()
     68 force Leaf=()
     69 force (Stem x)=force x
     70 force (Fork x y)=force x `seq` force y
     71 forceSpine :: T -> ()
     72 forceSpine Leaf=()
     73 forceSpine (Fork x xs)=x `seq` forceSpine xs
     74 forceSpine _=error "invalid list"
     75 
     76 pair :: T -> (T,T)
     77 pair (Fork a b)=(a,b)
     78 pair _=error "expected pair"
     79 text :: T -> String
     80 text=either error id . toString
     81 nat :: T -> Integer
     82 nat=either error id . toNumber
     83 ternary :: T -> String
     84 ternary t=go t [] where
     85   go Leaf rest='0':rest
     86   go (Stem x) rest='1':go x rest
     87   go (Fork x y) rest='2':go x (go y rest)
     88 fromTernary :: String -> T
     89 fromTernary s=case parse s of (t,"")->t; _->error "trailing ternary"
     90 parse :: String -> (T,String)
     91 parse ('0':xs)=(Leaf,xs)
     92 parse ('1':xs)=let (a,rest)=parse xs in (Stem a,rest)
     93 parse ('2':xs)=let (a,rest)=parse xs; (b,end)=parse rest in (Fork a b,end)
     94 parse _=error "invalid ternary"
     95 
     96 diagnostic :: T -> String
     97 diagnostic payload =
     98   let (d,_)=pair payload; (code,tail1)=pair d; (expected,fields)=pair tail1
     99       (_,locations)=pair fields; (location,_)=pair locations
    100       whereAt=case location of Leaf->""; _->let (line,rest)=pair location; (column,_)=pair rest
    101                                                            in " at "++show (nat line)++":"++show (nat column)
    102       c=nat code
    103       label | c==2 = ": expected token kind "++show (nat expected)
    104             | c==20 = ": unresolved name "++show (text expected)
    105             | c>=30 = ": expected "++show (text expected)
    106             | otherwise = ""
    107   in "Compiler diagnostic "++show c++whereAt++label
    108 
    109 definitions :: T -> Either String [(String,T)]
    110 definitions result=case pair result of
    111   (Leaf,payload)->Left (diagnostic payload)
    112   (Stem Leaf,payload)->let (ds,_)=pair payload in Right
    113     [(text name,program) | binding<-either error id (toList ds), let (name,program)=pair binding]
    114   _->error "invalid compiler tag"
    115 
    116 {-# OPAQUE compile #-}
    117 compile :: T -> T -> T -> T
    118 compile compiler env source=apply (apply compiler env) source
    119 
    120 main :: IO ()
    121 main = do
    122   args <- getArgs
    123   (dir,caseDir)<-case args of [d,c]->pure(d,c); _->die "usage: compiler-probe DATA CASE"
    124   start<-now
    125   (compiler,env)<-load dir
    126   source<-ofString <$> utf8 (caseDir++"/source")
    127   _<-evaluate (force source)
    128   expected<-lines <$> utf8 (caseDir++"/expected")
    129   run<-lines <$> utf8 (caseDir++"/run")
    130   loaded<-now
    131   result<-evaluate (compile compiler env source)
    132   whnf<-now
    133   let defs=definitions result
    134   -- Force export names/spine, not program trees: the site's selector boundary.
    135   _<-evaluate (case defs of Left msg->length msg; Right ds->sum [length name | (name,_)<-ds])
    136   named<-now
    137   valid<-evaluate $ case (expected,defs) of
    138     (["error",message],Left actual)->message==actual
    139     ("ok":rows,Right ds)->rows==[name++"\t"++ternary program | (name,program)<-ds]
    140     _->False
    141   unless valid (die "compiler golden mismatch")
    142   complete<-now
    143   case (defs,run) of
    144     (Right ds,name:wanted:arguments)->case lookup name ds of
    145       Just program->unless (ternary (foldl apply program (map fromTernary arguments))==wanted) (die "compiled program result mismatch")
    146       Nothing->die "missing compiled export"
    147     (Left _,[])->pure ()
    148     _->die "invalid run specification"
    149   executed<-now
    150   performGC
    151   stats<-getRTSStats
    152   printf "{\"load_s\":%.9f,\"whnf_s\":%.9f,\"names_s\":%.9f,\"complete_s\":%.9f,\"run_s\":%.9f,\"allocated_bytes\":%d,\"max_live_bytes\":%d,\"max_mem_in_use_bytes\":%d}\n"
    153     (loaded-start) (whnf-loaded) (named-whnf) (complete-named) (executed-complete)
    154     (allocated_bytes stats) (max_live_bytes stats) (max_mem_in_use_bytes stats)