summaryrefslogtreecommitdiff
path: root/tests/examples/SegFault.hs
blob: cf5e8109d11f003b6bef79f45a6d9bf3acb3390a (plain)
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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
{-# INCLUDE "Parrot_hsc.h" #-}
{-# LINE 1 "Parrot.hsc" #-}
{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-full-laziness -fno-cse #-}
{-# LINE 2 "Parrot.hsc" #-}

{-# LINE 3 "Parrot.hsc" #-}

module Pugs.Embed.Parrot where
import Data.IORef
import System.Cmd
import System.Process
import System.Directory
import System.IO
import System.IO.Unsafe
import Data.Maybe
import Control.Monad
import Pugs.Compat (getEnv, _PUGS_HAVE_POSIX)
import Pugs.Internals (encodeUTF8)

findExecutable' :: String -> IO (Maybe FilePath)
findExecutable' cmd = do
    dir <- getEnv "PARROT_PATH"
    if isJust dir then (do
        rv  <- findExecutableInDirectory (fromJust dir) cmd
        if isJust rv then return rv else findExecutable'') else do
    findExecutable''
    where
    findExecutable'' = do
        rv  <- findExecutable cmd
        if isJust rv then return rv else do
        cwd <- getCurrentDirectory
        rv  <- findExecutableInDirectory cwd cmd
        if isJust rv then return rv else do
        return Nothing

findExecutableInDirectory :: FilePath -> FilePath -> IO (Maybe FilePath)
findExecutableInDirectory dir cmd = do
    let file | _PUGS_HAVE_POSIX = dir ++ ('/':cmd)
             | otherwise        = dir ++ ('\\':cmd) ++ ".exe"
    ok <- doesFileExist file
    return $ if ok then (Just file) else Nothing

findParrot :: IO FilePath
findParrot = do
    rv <- findExecutable' "parrot"
    case rv of
        Nothing     -> fail "Cannot find the parrot executable in PATH"
        Just cmd    -> return cmd

evalParrotFile :: FilePath -> IO ()
evalParrotFile file = do
    cmd <- findParrot
    -- parrot -j is fatal on systems where jit is not supported,
    -- so we use the next fastest CGP core.
    args <- getEnv "PUGS_PARROT_OPTS"
    let args' | isJust args && fromJust args /= "" = fromJust args
              | otherwise                          = "-f"
    rawSystem cmd [args', file]
    return ()

evalParrot :: String -> IO ()
evalParrot str = do
    tmp         <- getTemporaryDirectory
    (file, fh)  <- openTempFile tmp "pugs.pir"
    hPutStr fh str
    hClose fh
    evalParrotFile file
    removeFile file

evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String
evalPGE path match rule subrules = do
    (inp, out, err, pid) <- initPGE path
    (`mapM` subrules) $ \(name, rule) -> do
        let nameStr = escape name
            ruleStr = escape rule
        hPutStrLn inp $ unwords
            ["add_rule", show (length nameStr), show (length ruleStr)]
        hPutStrLn inp nameStr
        hPutStrLn inp ruleStr
    let matchStr = escape match
        ruleStr  = escape rule
    hPutStrLn inp $ unwords
        ["match", show (length matchStr), show (length ruleStr)]
    hPutStrLn inp $ matchStr
    hPutStrLn inp $ ruleStr
    hFlush inp
    rv <- hGetLine out
    case rv of
        ('O':'K':' ':sizeStr) -> do
            size <- readIO sizeStr
            rv   <- sequence (replicate size (hGetChar out))
            ln   <- hGetLine out
            return $ rv ++ ln
        _ -> do
            errMsg  <- hGetContents err
            rv      <- waitForProcess pid
            writeIORef _ParrotInterp Nothing
            let msg | null errMsg = show rv
                    | otherwise   = errMsg
            fail $ "*** Running external 'parrot' failed:\n" ++ msg
    where
    escape = escape . encodeUTF8
    _escape "" = ""
    _escape ('\\':xs) = "\\\\" ++ _escape xs
    _escape ('\n':xs) = "\\n" ++ _escape xs
    _escape (x:xs) = (x:_escape xs)

initPGE :: FilePath -> IO ParrotInterp
initPGE path = do
    rv <- readIORef _ParrotInterp
    case rv of
        Just interp@(_, _, _, pid) -> do
            gone <- getProcessExitCode pid
            if isNothing gone then return interp else do
            writeIORef _ParrotInterp Nothing
            initPGE path
        Nothing -> do
            cmd <- findParrot
            interp <- runInteractiveProcess cmd ["run_pge.pir"] (Just path) Nothing
            writeIORef _ParrotInterp (Just interp)
            return interp

type ParrotInterp = (Handle, Handle, Handle, ProcessHandle)

{-# NOINLINE _ParrotInterp #-}
_ParrotInterp :: IORef (Maybe ParrotInterp)
_ParrotInterp = unsafePerformIO $ newIORef Nothing

_DoCompile :: Maybe (IORef (String -> FilePath -> String -> IO String))
_DoCompile = Nothing


{-# LINE 387 "Parrot.hsc" #-}