module Language.Copilot.Dispatch
(dispatch, BackEnd(..), AtomToC(..), Interpreted(..), Iterations, Verbose(..)) where
import Language.Copilot.Core
import Language.Copilot.Analyser (check, getExternalVars)
import Language.Copilot.Interpreter
import Language.Copilot.AtomToC
import Language.Copilot.Compiler
import Language.Copilot.PrettyPrinter ()
import qualified Language.Atom as A
import qualified Data.Map as M
import System.Directory
import System.Process
import System.IO
import Control.Monad
data AtomToC = AtomToC
{ cName :: Name
, gccOpts :: String
, getPeriod :: Maybe Period
, interpreted :: Interpreted
, outputDir :: String
, compiler :: String
, sim :: Bool
, prePostCode :: (Maybe String, Maybe String)
, arrDecs :: [(String, Int)]
, clock :: Maybe A.Clock
}
data BackEnd = Opts AtomToC
| Interpreter
data Interpreted = Interpreted | NotInterpreted
type Iterations = Int
data Verbose = OnlyErrors | DefaultVerbose | Verbose deriving Eq
dispatch :: LangElems -> Vars -> BackEnd -> Iterations -> Verbose -> IO ()
dispatch elems inputExts backEnd iterations verbose =
do
hSetBuffering stdout LineBuffering
mapM_ putStrLn preludeText
isValid <-
case check (strms elems) of
Just x -> print x >> return False
Nothing -> return True
when isValid $
let interpretedLines = showVars (interpretStreams (strms elems) trueInputExts)
iterations
in case backEnd of
Interpreter ->
do
unless allInputsPresents $ error errMsg
mapM_ putStrLn interpretedLines
Opts opts ->
let isInterpreted =
case (interpreted opts) of
Interpreted -> True
NotInterpreted -> False
dirName = outputDir opts
in do
putStrLn $ "Trying to create the directory " ++ dirName
++ " (if missing) ..."
createDirectoryIfMissing False dirName
copilotToC elems allExts trueInputExts opts isVerbose
let copy ext = copyFile (cName opts ++ ext)
(dirName ++ cName opts ++ ext)
let delete ext = do
f0 <- canonicalizePath (cName opts ++ ext)
f1 <- canonicalizePath (dirName ++ cName opts ++ ext)
unless (f0 == f1) $ removeFile (cName opts ++ ext)
putStrLn $ "Moving " ++ cName opts ++ ".c and " ++ cName opts
++ ".h to " ++ dirName ++ " ..."
copy ".c"
copy ".h"
delete ".c"
delete ".h"
when (sim opts) (gccCall (Opts opts))
when ((isInterpreted || isExecuted) && not allInputsPresents) $
error errMsg
when isExecuted $ execute (strms elems) (dirName ++ cName opts)
trueInputExts isInterpreted
interpretedLines iterations isSilent
where
errMsg = "The interpreter does not have values for some of the external variables."
isVerbose = verbose == Verbose
isSilent = verbose == OnlyErrors
isExecuted = iterations /= 0
allExts = getExternalVars (strms elems)
(trueInputExts :: StreamableMaps [] , allInputsPresents :: Bool) =
filterStreamableMaps inputExts (map (\(a,v,r) -> (a, show v, r)) allExts)
copilotToC :: LangElems -> [Exs] -> Vars -> AtomToC -> Bool -> IO ()
copilotToC elems allExts trueInputExts opts isVerbose =
let cFileName = cName opts
(p', program) = copilotToAtom elems (getPeriod opts) cFileName
(preCode, postCode) =
getPrePostCode (sim opts) (prePostCode opts) cFileName
(strms elems) allExts (map (\(x,y) -> (ExtV x,y))
(arrDecs opts)) trueInputExts p'
atomConfig = A.defaults
{ A.cCode = \_ _ _ -> (preCode, postCode)
, A.cRuleCoverage = False
, A.cAssert = False
, A.hardwareClock = clock opts
, A.cStateName = "copilotState" ++ cFileName
}
in do
putStrLn $ "Compiling Copilot specs to C ..."
(sched, _, _, _, _) <- A.compile cFileName atomConfig program
when isVerbose (putStrLn $ A.reportSchedule sched)
putStrLn $ "Generated " ++ cFileName ++ ".c and " ++ cFileName ++ ".h"
gccCall :: BackEnd -> IO ()
gccCall backend =
case backend of
Interpreter -> error "Impossible: gccCall called with Interpreter."
Opts opts ->
let dirName = outputDir opts
programName = cName opts
in
do
let command = compiler opts ++ " " ++ dirName ++ cName opts
++ ".c" ++ " -o " ++ dirName ++ programName
++ " " ++ gccOpts opts
putStrLn "Calling the C compiler ..."
putStrLn command
_ <- system command
return ()
execute :: StreamableMaps Spec -> String -> Vars -> Bool -> [String] -> Iterations -> Bool -> IO ()
execute streams programName trueInputExts isInterpreted interpretedLines iterations isSilent =
do (Just hin, Just hout, _, _) <- createProcess processConfig
hSetBuffering hout LineBuffering
hSetBuffering hin LineBuffering
when isInterpreted
(do putStrLn "\n *** Checking the randomly-generated Copilot specification: ***\n"
print streams)
let inputVar v (val:vals) ioVars =
do hPutStr hin (showAsC val ++ " \n")
hFlush hin
vars <- ioVars
return $ updateSubMap (\m -> M.insert v vals m) vars
inputVar _ [] _ = error "Impossible : empty inputVar"
executePeriod _ [] 0 = putStrLn "Execution complete."
executePeriod _ [] _ = error "Impossible : empty ExecutePeriod"
executePeriod inputExts (inLine:inLines) n =
when (n > 0) $
do nextInputExts <- foldStreamableMaps inputVar inputExts (return emptySM)
line <- hGetLine hout
let nextPeriod =
(unless isSilent $ putStrLn line) >>
executePeriod nextInputExts inLines (n 1)
if isInterpreted
then if inLine == line
then nextPeriod
else error $ unlines
[ "Failure: interpreter /= compiler"
, " program name: " ++ programName
, " interpreter: " ++ inLine
, " compiler: " ++ line
]
else nextPeriod
firstInputExts <- foldStreamableMaps inputVar trueInputExts (return emptySM)
executePeriod firstInputExts interpretedLines iterations
where
processConfig =
(shell $ programName ++ " " ++ show iterations)
{std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stdout}
showVars :: Vars -> Int-> [String]
showVars interpretedVars n =
showVarsLine interpretedVars 0
where
showVarsLine inVs i =
if i == n
then []
else
let (string, inVs') = foldStreamableMaps prettyShow inVs ("", emptySM)
endString = showVarsLine inVs' (i + 1)
beginString = "period: " ++ show i ++ " " ++ string
in
beginString:endString
prettyShow v l (s, vs) =
let s' = v ++ ": " ++ showAsC (head l) ++ " " ++ s
vs' = updateSubMap (\ m -> M.insert v (tail l) m) vs in
(s', vs')
preludeText :: [String]
preludeText =
[ ""
, "========================================================================="
, " CoPilot, a stream language for generating hard real-time C monitors. "
, "========================================================================="
, "Copyright, Galois, Inc. 2010"
, "BSD3 License"
, "Website: http://leepike.github.com/Copilot/"
, "Maintainer: Lee Pike <leepike--at--gmail.com> (remove dashes)."
, "Usage: > help"
, "========================================================================="
, ""
]