blob: ea461613424b482c8e4c361fd28f7f47fbc81bfe (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
-- MIT License, Copyright (c) 2024 Marvin Borner
-- BLoC format is used in combination with BLoCade the BLoC-aid.
module Target
( toTarget
) where
import Binary
import Control.Exception
import qualified Data.BitString as Bit
import qualified Data.ByteString.Lazy.Char8 as Byte
import Helper
import System.IO
import System.Process
tryIO :: IO a -> IO (Either IOException a)
tryIO = try
compile :: Expression -> String -> IO (Failable String)
compile e target = do
res <- tryIO $ createProcess
(shell $ "bloc -v -i - --from-blc | blocade -v -i - -t " <> target)
{ std_in = CreatePipe
, std_out = CreatePipe
}
case res of
Right (Just inH, Just outH, _, _) -> do
let binary = toBinary e
hSetBuffering inH NoBuffering
hSetBuffering outH NoBuffering
hSetBinaryMode outH True
hIsOpen inH >>= print
hIsWritable inH >>= print
putStrLn "sending binary"
hPutStrLn inH binary
hPutStr inH "\0"
hFlush inH
content <- hGetContents' outH
hClose outH
hClose inH
return $ case content of
"" -> Left $ OptimizerError "blocade returned empty string"
_ -> Right content
_ -> return $ Left $ OptimizerError "can't read from blocade"
-- TODO: add more targets (including other PL compilation)
toExpression :: String -> String -> Expression
toExpression "blc" = fromBinary
toExpression "unblc" = fromBinary
toExpression "bblc" =
fromBinary . fromBitString . Bit.bitStringLazy . Byte.pack
toExpression "unbblc" =
fromBinary . fromBitString . Bit.bitStringLazy . Byte.pack
toExpression _ = invalidProgramState
toTarget :: EvalConf -> Expression -> IO Expression
toTarget conf e = do
let target = _toTarget conf
case target of
"" -> return e -- No target, fallback to unoptimized expression
_ -> do
maybeRes <- compile e target
case maybeRes of
Left err -> do
print err
return e -- Fallback to unoptimized expression
Right res -> return $ toExpression target res
|
