8f767ff0d4
This makes sure that we catch all leftover instances of using SYB to do generic operations that we should be using Polyplate for instead. Most modules should only import Data, and possibly Typeable.
264 lines
8.1 KiB
Haskell
264 lines
8.1 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2008 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | Generate CHP code from the AST
|
|
--
|
|
-- These are the things that need to be done before the AST reaches this backend:
|
|
--
|
|
-- Need to convert anything that isn't a communication/PAR/ALT into a Continuation
|
|
-- Passing Style (CPS). WHILEs become IFs in recursive PROCs. SEQ replicators become
|
|
-- recursive PROCs.
|
|
--
|
|
-- Eventually, the code passed here should have only the following in SEQ blocks:
|
|
--
|
|
-- * Communications
|
|
--
|
|
-- * ALTs
|
|
--
|
|
-- * PARs
|
|
--
|
|
-- * assignments (from variables or function calls)
|
|
--
|
|
-- * process calls
|
|
--
|
|
-- It should never have SEQs nested in SEQs
|
|
module GenerateCHP where
|
|
|
|
import Control.Monad.State
|
|
import Control.Monad.Trans
|
|
import Data.Char
|
|
import Data.Generics (Data, showConstr, toConstr)
|
|
import Data.List
|
|
import Data.Maybe
|
|
import System.IO
|
|
import Text.Printf
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import EvalLiterals
|
|
import Metadata
|
|
import Pass
|
|
import Utils
|
|
|
|
-- Borrowed from GenerateCBased, and simplified:
|
|
|
|
-- A handle/string buffer, the current line, and indent stack (push at head)
|
|
type CGen = StateT (Either [String] Handle, String, [Int]) PassM
|
|
|
|
instance Die CGen where
|
|
dieReport err = lift $ dieReport err
|
|
|
|
instance CSMR CGen where
|
|
getCompState = lift getCompState
|
|
|
|
tell :: [String] -> CGen ()
|
|
tell x = do (hb, cur, curIndent:indentStack) <- get
|
|
let cur' = replace ("\n","\n" ++ replicate curIndent ' ') (cur++concat x)
|
|
let (cur'', prevLines)
|
|
= transformPair reverse reverse $
|
|
span (/= '\n') (reverse cur')
|
|
hb' <- case hb of
|
|
Left prev -> return $ Left (prev ++ lines prevLines)
|
|
Right h -> do liftIO $ hPutStr h prevLines
|
|
return hb
|
|
put (hb, cur'', curIndent:indentStack)
|
|
|
|
pushIndent :: CGen ()
|
|
pushIndent = modify $ \(hb, cur, indents) -> (hb, cur, length cur : indents)
|
|
|
|
popIndent :: CGen ()
|
|
popIndent = do
|
|
(hb, cur, _:indents) <- get
|
|
if all (== ' ') cur
|
|
then put (hb, replicate (head indents) ' ', indents)
|
|
else tell ["\n"] >> popIndent
|
|
|
|
withIndent :: CGen () -> CGen ()
|
|
withIndent f = pushIndent >> f >> popIndent
|
|
|
|
genName :: A.Name -> CGen ()
|
|
genName n = let unders = [if c == '.' then '_' else c | c <- A.nameName n] in
|
|
-- Prefix underscore to anything beginning with upper-case:
|
|
if isUpper (head unders)
|
|
then tell ["_",unders]
|
|
else tell [unders]
|
|
|
|
|
|
genMissing = flip genMissing' ()
|
|
|
|
genMissing' :: Data a => String -> a -> CGen()
|
|
genMissing' s x = tell ["(error \"",s,": ", showConstr $ toConstr x,"\")"] -- for now, everthing is missing!
|
|
-- TODO in future generate a Die error
|
|
|
|
genHeader :: CGen ()
|
|
genHeader
|
|
= tell ["import GHC.Prim\n"
|
|
,"import Control.Concurrent.CHP\n"
|
|
,"\n"
|
|
]
|
|
|
|
generateCHP :: Handle -> A.AST -> PassM ()
|
|
generateCHP h tr
|
|
= flip evalStateT (Right h, "", [0]) $ genHeader >> genAST tr
|
|
|
|
genAST :: A.AST -> CGen ()
|
|
genAST = genStructured False return
|
|
|
|
genStructured :: Data a => Bool -> (a -> CGen()) -> A.Structured a -> CGen ()
|
|
genStructured False genOnly (A.Spec m spec scope)
|
|
= do genSpec spec
|
|
genStructured False genOnly scope
|
|
genStructured True genOnly (A.Spec m spec scope)
|
|
= do tell ["let "]
|
|
withIndent $ genSpec spec
|
|
tell ["in "]
|
|
withIndent $ genStructured True genOnly scope
|
|
genStructured addLet genOnly (A.ProcThen m proc scope) = genMissing "genStructured ProcThen"
|
|
>> tell ["λn"] >> genStructured addLet genOnly scope
|
|
genStructured _ genOnly (A.Only m item) = genOnly item
|
|
genStructured addLet genOnly (A.Several m strs) = mapM_ (genStructured addLet genOnly) strs
|
|
|
|
-- | Should output a spec, or nothing
|
|
genSpec :: A.Specification -> CGen ()
|
|
genSpec (A.Specification _ n (A.Proc _ _ params body))
|
|
= do genName n
|
|
tell [" :: "]
|
|
mapM doFormalAndArrow params -- TODO handle return vals
|
|
tell [" CHP ()\n"]
|
|
genName n
|
|
sequence [genName pn >> tell [" "] | A.Formal _ _ pn <- params]
|
|
tell ["= "]
|
|
withIndent $ genProcess (fromJust body)
|
|
where
|
|
doFormalAndArrow :: A.Formal -> CGen ()
|
|
doFormalAndArrow (A.Formal _ t _)
|
|
= genType t >> tell [" -> "]
|
|
genSpec (A.Specification _ n (A.Declaration _ t))
|
|
= do genName n
|
|
tell [" :: "]
|
|
genType t
|
|
tell ["\n"]
|
|
genName n
|
|
tell [" = error \"Variable ", A.nameName n, " used uninitialised\"\n"]
|
|
{-
|
|
genSpec (A.Specification _ n (A.IsExpr _ _ t e))
|
|
= do genName n
|
|
tell [" :: "]
|
|
genType t
|
|
tell ["\n"]
|
|
genName n
|
|
tell [" = "]
|
|
genExpression e
|
|
tell ["\n"]
|
|
-}
|
|
genSpec _ = genMissing "genSpec" >> tell ["\n"]
|
|
|
|
genProcess :: A.Process -> CGen ()
|
|
genProcess (A.Seq _ str) = tell ["do "] >> withIndent (genStructured True genProcess str)
|
|
genProcess (A.ProcCall _ n params)
|
|
= do genName n
|
|
sequence [tell [" "] >> genActual p | p <- params]
|
|
tell ["\n"]
|
|
genProcess p = genMissing' "genProcess" p >> tell ["\n"]
|
|
|
|
genActual :: A.Actual -> CGen ()
|
|
genActual (A.ActualVariable v) = genVariable v
|
|
genActual (A.ActualExpression e) = genExpression e
|
|
|
|
genVariable :: A.Variable -> CGen ()
|
|
genVariable (A.Variable _ n) = genName n
|
|
genVariable v = genMissing' "genVariable" v
|
|
|
|
genExpression :: A.Expression -> CGen ()
|
|
genExpression (A.Literal _ t repr)
|
|
= do tell ["(("]
|
|
genLiteralRepr repr
|
|
tell [")::"]
|
|
genType t
|
|
tell [")"]
|
|
genExpression (A.ExprVariable _ v) = genVariable v
|
|
genExpression (A.True _) = tell ["True"]
|
|
genExpression (A.False _) = tell ["False"]
|
|
genExpression e = genMissing' "genExpression" e
|
|
|
|
seqComma :: [CGen ()] -> CGen ()
|
|
seqComma ps = sequence_ $ intersperse (tell [","]) ps
|
|
|
|
genLiteralRepr :: A.LiteralRepr -> CGen ()
|
|
genLiteralRepr (A.ArrayListLiteral _ (A.Several _ elems))
|
|
= do tell ["newListArray (0," ++ show (length elems - 1) ++ ") ["]
|
|
seqComma $ map genArrayElem elems
|
|
tell ["]"]
|
|
genLiteralRepr (A.IntLiteral _ str) = tell [str]
|
|
genLiteralRepr (A.RealLiteral _ str) = tell [str]
|
|
genLiteralRepr (A.ByteLiteral m str)
|
|
= tell ["\'"] >> genByteLiteral m str >> tell ["\'"]
|
|
genLiteralRepr _ = genMissing "genLiteralRepr"
|
|
|
|
genByteLiteral :: Meta -> String -> CGen ()
|
|
genByteLiteral m s
|
|
= do c <- evalByte m s
|
|
tell [convByte c]
|
|
|
|
convByte :: Char -> String
|
|
convByte '\'' = "\\'"
|
|
convByte '"' = "\\\""
|
|
convByte '\\' = "\\\\"
|
|
convByte '\r' = "\\r"
|
|
convByte '\n' = "\\n"
|
|
convByte '\t' = "\\t"
|
|
convByte c
|
|
| o == 0 = "\\0"
|
|
| (o < 32 || o > 127) = printf "\\%03o" o
|
|
| otherwise = [c]
|
|
where o = ord c
|
|
|
|
genArrayElem :: A.Structured A.Expression -> CGen ()
|
|
genArrayElem (A.Only _ e) = genExpression e
|
|
genArrayElem _ = genMissing "genArrayElem"
|
|
|
|
genType :: A.Type -> CGen ()
|
|
genType A.Bool = tell ["Bool"]
|
|
genType A.Byte = tell ["Word8"]
|
|
genType A.UInt16 = tell ["Word16"]
|
|
genType A.UInt32 = tell ["Word32"]
|
|
genType A.UInt64 = tell ["Word64"]
|
|
genType A.Int8 = tell ["Int8"]
|
|
genType A.Int16 = tell ["Int16"]
|
|
genType A.Int = tell ["Int32"]
|
|
genType A.Int32 = tell ["Int32"]
|
|
genType A.Int64 = tell ["Int64"]
|
|
genType A.Real32 = tell ["Float"]
|
|
genType A.Real64 = tell ["Double"]
|
|
genType (A.Array _ t) = tell ["(IOUArray Int32 "] >> genType t >> tell [")"]
|
|
genType (A.List t) = tell["(Seq "] >> genType t >> tell [")"]
|
|
genType (A.ChanEnd dir attr inner)
|
|
= do tell ["(", case dir of
|
|
A.DirInput -> "Chanin"
|
|
A.DirOutput -> "Chanout"]
|
|
tell ["(IOUArray Word8)"]
|
|
-- genType inner
|
|
tell [")"]
|
|
genType (A.Chan attr inner)
|
|
= do tell ["(One2OneChannel (IOUArray Word8))"]
|
|
-- genType inner
|
|
genType _ = genMissing "genType"
|
|
|
|
--TODO compile IFs into case. And case into case.
|