diff --git a/fco/OccamTypes.hs b/fco/AST.hs similarity index 98% rename from fco/OccamTypes.hs rename to fco/AST.hs index 3000307..f90d2f0 100644 --- a/fco/OccamTypes.hs +++ b/fco/AST.hs @@ -1,8 +1,8 @@ -- Data types for occam abstract syntax -- This is intended to be imported qualified: --- import qualified OccamTypes as O +-- import qualified AST as O -module OccamTypes where +module AST where import Data.Generics diff --git a/fco/ASTPasses.hs b/fco/ASTPasses.hs new file mode 100644 index 0000000..ccdd112 --- /dev/null +++ b/fco/ASTPasses.hs @@ -0,0 +1,21 @@ +-- Parses across the AST + +module ASTPasses (astPasses) where + +import qualified AST as A +import Data.Generics +import Control.Monad.State + +astPasses = + [ ("Silly monad example", numberPass) + ] + +number :: A.Name -> State Int A.Name +number (A.Name s) = do + i <- get + put (i + 1) + return $ A.Name (s ++ "." ++ (show i)) + +numberPass :: A.Process -> A.Process +numberPass n = evalState (everywhereM (mkM number) n) 0 + diff --git a/fco/Main.hs b/fco/Main.hs index 53e2bee..018a721 100644 --- a/fco/Main.hs +++ b/fco/Main.hs @@ -8,33 +8,19 @@ import System.Console.GetOpt import System.IO import Parse -import Tree import SExpression import Pass -import PhaseSource -import PhaseIntermediate -import PhaseOutput +import PTPasses +import PTToAST +import ASTPasses -import TreeToAST - -phaseList = [phaseSource, phaseIntermediate, phaseOutput] - -doPhases :: [Phase] -> Node -> Progress -> IO Node -doPhases [] n progress = do return n -doPhases (p:ps) n progress = do - n' <- runPhase p n progress - n'' <- doPhases ps n' progress - return n'' - -data Flag = ParseOnly | SOccamOnly | RawParseOnly | ASTOnly | Verbose +data Flag = ParseOnly | SOccamOnly | Verbose deriving (Eq, Show) options :: [OptDescr Flag] options = [ Option [] ["parse-tree"] (NoArg ParseOnly) "parse input files and output S-expression parse tree" , Option [] ["soccam"] (NoArg SOccamOnly) "parse input files and output soccam" - , Option [] ["raw-parse-tree"] (NoArg RawParseOnly) "parse input files and output parse tree" - , Option [] ["ast"] (NoArg ASTOnly) "parse input files and output AST" , Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on" ] @@ -63,26 +49,33 @@ main = do progress $ "Compiling " ++ fn progress "" + progress $ "{{{ Preprocessor" preprocessed <- readSource fn - progress $ "Preprocessed: " progress $ numberedListing preprocessed - progress $ "" + progress $ "}}}" - let parsed = parseSource preprocessed + progress $ "{{{ Parser" + let pt = parseSource preprocessed + progress $ show pt + progress $ "}}}" if ParseOnly `elem` opts then do - putStrLn $ show (nodeToSExp parsed) + putStrLn $ show (nodeToSExp pt) else if SOccamOnly `elem` opts then do - putStrLn $ show (nodeToSOccam parsed) - else if RawParseOnly `elem` opts then do - putStrLn $ show parsed - else if ASTOnly `elem` opts then do - putStrLn $ show (treeToAST parsed) + putStrLn $ show (nodeToSOccam pt) else do - progress $ "Parsed: " ++ show parsed - progress "" + progress $ "{{{ PT passes" + pt' <- runPasses ptPasses progress pt + progress $ "}}}" - out <- doPhases phaseList parsed progress - progress "" - progress $ "After phases: " ++ show out + progress $ "{{{ PT to AST" + let ast = ptToAST pt' + progress $ show ast + progress $ "}}}" + + progress $ "{{{ AST passes" + ast' <- runPasses astPasses progress ast + progress $ "}}}" + + progress $ "Done" diff --git a/fco/Makefile b/fco/Makefile index 7df5e62..d92645f 100644 --- a/fco/Makefile +++ b/fco/Makefile @@ -1,24 +1,19 @@ all: fco sources = \ - BaseTransforms.hs \ - OccamTypes.hs \ + AST.hs \ + ASTPasses.hs \ Parse.hs \ Pass.hs \ - PhaseIntermediate.hs \ - PhaseOutput.hs \ - PhaseSource.hs \ + PT.hs \ + PTPasses.hs \ SExpression.hs \ - Tree.hs \ - TreeToAST.hs \ + PTToAST.hs \ Main.hs fco: $(sources) ghc -fglasgow-exts -o fco --make Main -BaseTransforms.hs: Tree.hs make-passthrough.py - python make-passthrough.py - tests = $(wildcard test*.occ) test: fco $(tests) diff --git a/fco/Tree.hs b/fco/PT.hs similarity index 96% rename from fco/Tree.hs rename to fco/PT.hs index a59a59a..f5d6f36 100644 --- a/fco/Tree.hs +++ b/fco/PT.hs @@ -1,8 +1,10 @@ -- occam parse tree -- This is intended to be imported qualified: --- import qualified Tree as N +-- import qualified PT as N -module Tree where +module PT where + +import Data.Generics data Node = -- {{{ BEGIN baseTransformOc @@ -160,5 +162,5 @@ data Node = | CCode String -- }}} END - deriving (Show, Eq) + deriving (Show, Eq, Typeable, Data) diff --git a/fco/PTPasses.hs b/fco/PTPasses.hs new file mode 100644 index 0000000..8d765c5 --- /dev/null +++ b/fco/PTPasses.hs @@ -0,0 +1,8 @@ +-- Passes across the parse tree + +module PTPasses (ptPasses) where + +import qualified PT as P + +ptPasses = [] + diff --git a/fco/TreeToAST.hs b/fco/PTToAST.hs similarity index 98% rename from fco/TreeToAST.hs rename to fco/PTToAST.hs index a1a2182..b465b02 100644 --- a/fco/TreeToAST.hs +++ b/fco/PTToAST.hs @@ -1,9 +1,9 @@ -- Convert the parse tree into the AST -module TreeToAST (treeToAST) where +module PTToAST (ptToAST) where -import qualified Tree as N -import qualified OccamTypes as O +import qualified PT as N +import qualified AST as O doName :: N.Node -> O.Name doName (N.Name s) = O.Name s @@ -245,6 +245,6 @@ doProcess n = case n of N.PriAltRep _ _ -> O.Alt True $ doAlt n N.ProcCall p es -> O.ProcCall (doName p) (map doExpression es) -treeToAST :: N.Node -> O.Process -treeToAST = doProcess +ptToAST :: N.Node -> O.Process +ptToAST = doProcess diff --git a/fco/Parse.hs b/fco/Parse.hs index c95cbc9..2239648 100644 --- a/fco/Parse.hs +++ b/fco/Parse.hs @@ -8,7 +8,7 @@ import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language (emptyDef) import qualified IO -import qualified Tree as N +import qualified PT as N -- ------------------------------------------------------------- diff --git a/fco/Pass.hs b/fco/Pass.hs index 141111a..bfdeceb 100644 --- a/fco/Pass.hs +++ b/fco/Pass.hs @@ -1,50 +1,21 @@ --- Defining passes on the tree +-- Defining and running passes across some type of tree module Pass where -import qualified Tree as N import Control.Monad.State type Progress = (String -> IO ()) -type ITransform st = N.Node -> State st N.Node --- This is actually a fraction of a pass: an operation upon the tree. --- The arguments are: --- - "next": the next pass to try if this one doesn't match; --- - "top": the pass to use recursively on subnodes; --- - the input node. -type Transform st = ITransform st -> ITransform st -> ITransform st +type Pass t = t -> t -runTransforms :: st -> [Transform st] -> N.Node -> N.Node -runTransforms initState passes node = evalState (top node) initState - where - fail :: ITransform st - fail n = error $ "No match for node: " ++ (show n) +type PassList t = [(String, Pass t)] - makeTransformList (p:[]) = [p fail top] - makeTransformList (p:ps) = p (head rest) top : rest - where rest = makeTransformList ps - - passList = makeTransformList passes - - top = head passList - -type Pass = N.Node -> N.Node - -makePass :: st -> Transform st -> [Transform st] -> Pass -makePass initState t bases = runTransforms initState (t : bases) - -data Phase = Phase String [(String, Pass)] - -runPhase :: Phase -> N.Node -> Progress -> IO N.Node -runPhase (Phase name passes) n progress = do - progress $ "Phase: " ++ name - runPhase' (reverse passes) n - where - runPhase' :: [(String, Pass)] -> N.Node -> IO N.Node - runPhase' [] n = do return n - runPhase' ((name, pass):passes) n = do - rest <- runPhase' passes n - progress $ " Pass: " ++ name - return $ pass rest +runPasses :: Show t => PassList t -> Progress -> t -> IO t +runPasses [] _ d = return d +runPasses ((name, pass):ps) progress d = do + progress $ "{{{ Pass: " ++ name + let d' = pass d + progress $ show d' + progress $ "}}}" + runPasses ps progress d' diff --git a/fco/PhaseIntermediate.hs b/fco/PhaseIntermediate.hs deleted file mode 100644 index 3b24357..0000000 --- a/fco/PhaseIntermediate.hs +++ /dev/null @@ -1,60 +0,0 @@ --- Intermediate passes - -module PhaseIntermediate (phaseIntermediate) where - -import qualified Tree as N -import Pass -import BaseTransforms -import Control.Monad.State -import Data.Map as Map - -bases = [baseTransformOc, baseTransformInt] - -phaseIntermediate - = (Phase "Intermediate mangling" - [ - ("Mark declarations", makePass () markDecls bases) --- , ("Unique identifiers", makePass (0, Map.empty) uniqueIdentifiers bases) - ]) - -nestDecls :: [(N.Node, N.Node)] -> N.Node -> N.Node -nestDecls l n = foldl (\a b -> b a) n [N.IntDecl n d | (N.Name n, d) <- l] - -markDecls :: Transform () -markDecls next top node - = case node of - -- FIXME same for functions - N.Decl d body -> do - body' <- top body - return $ case d of - N.Vars t ns -> nestDecls [(n, t) | n <- ns] body' - N.Is (N.Name n) _ -> N.IntDecl n d body' - N.IsType (N.Name n) _ _ -> N.IntDecl n d body' - N.ValIs (N.Name n) _ -> N.IntDecl n d body' - N.ValIsType (N.Name n) _ _ -> N.IntDecl n d body' - N.DataType (N.Name n) _ -> N.IntDecl n d body' - N.Protocol (N.Name n) _ -> N.IntDecl n d body' - N.FuncIs (N.Name n) _ _ _ -> N.IntDecl n d body' - N.Retypes (N.Name n) _ _ -> N.IntDecl n d body' - N.ValRetypes (N.Name n) _ _ -> N.IntDecl n d body' - N.Reshapes (N.Name n) _ _ -> N.IntDecl n d body' - N.ValReshapes (N.Name n) _ _ -> N.IntDecl n d body' - _ -> error ("Unhandled type of declaration: " ++ (show d)) - _ -> next node - -uniqueIdentifiers :: Transform (Int, Map.Map String String) -uniqueIdentifiers next top node - = case node of - N.IntDecl name def body -> do - (n, ids) <- get - let newname = name ++ "_" ++ (show n) - put (n + 1, Map.insert name newname ids) - def' <- top def - body' <- top body - modify (\(n, _) -> (n, ids)) - return $ N.IntDecl newname def' body' - N.Name s -> do - (_, ids) <- get - return $ if Map.member s ids then N.Name (Map.findWithDefault "" s ids) else error ("Unknown identifier: " ++ s) - _ -> next node - diff --git a/fco/PhaseOutput.hs b/fco/PhaseOutput.hs deleted file mode 100644 index cd4e6f1..0000000 --- a/fco/PhaseOutput.hs +++ /dev/null @@ -1,21 +0,0 @@ --- C output passes - -module PhaseOutput (phaseOutput) where - -import Tree -import Pass -import BaseTransforms - -bases = [baseTransformOc, baseTransformInt, baseTransformC] - -phaseOutput - = (Phase "C output" - [ - ("Convert expressions", makePass () convExpressions bases) - ]) - -convExpressions :: Transform () -convExpressions next top node - = case node of - _ -> next node - diff --git a/fco/PhaseSource.hs b/fco/PhaseSource.hs deleted file mode 100644 index 63e4266..0000000 --- a/fco/PhaseSource.hs +++ /dev/null @@ -1,31 +0,0 @@ --- Source-rewriting passes - -module PhaseSource (phaseSource) where - -import qualified Tree as N -import Pass -import BaseTransforms -import Control.Monad.State - -bases = [baseTransformOc] - -phaseSource - = (Phase "Source rewriting" - [ - ("Simplify", makePass () simplify bases), - ("C-ify identifiers", makePass () cifyIdentifiers bases) - ]) - -simplify :: Transform () -simplify next top node - = case node of - -- FIXME rewrite stuff like N.FuncIs -> N.Func - -- FIXME could we even rewrite procs and functions to the same thing? - _ -> next node - -cifyIdentifiers :: Transform () -cifyIdentifiers next top node - = case node of - N.Name n -> return $ N.Name [if c == '.' then '_' else c | c <- n] - _ -> next node - diff --git a/fco/SExpression.hs b/fco/SExpression.hs index 148959a..b7e8d2c 100644 --- a/fco/SExpression.hs +++ b/fco/SExpression.hs @@ -3,7 +3,7 @@ module SExpression where import List -import qualified Tree as N +import qualified PT as N data SExp = Item String | List [SExp] diff --git a/fco/make-passthrough.py b/fco/make-passthrough.py deleted file mode 100644 index c2ff70d..0000000 --- a/fco/make-passthrough.py +++ /dev/null @@ -1,82 +0,0 @@ -#!/usr/bin/python -# Generate the base transforms from the data type definition in Tree. - -import os, sys, re - -def die(*s): - print >>sys.stderr, "Fatal: " + "".join(map(str, s)) - sys.exit(1) - -def update_def(func, f, newf): - newf.write("\n" + func + " :: Transform st\n") - newf.write(func + " next top node\n") - newf.write(" = case node of\n") - while True: - s = f.readline() - if s == "": - die("Unexpected EOF during Node definition") - elif s.strip().startswith("-- }}} END"): - break - - s = s.strip() - if s == "" or s.startswith("--"): - continue - s = s.replace("| ", "") - - fields = s.split() - name = "N." + fields[0] - args = fields[1:] - - lhs = [] - lines = [] - rhs = [] - i = 1 - for arg in args: - n = "a" + str(i) - i += 1 - - lhs.append(n) - var = "v" + n - if arg == "Node": - lines.append(var + " <- top " + n) - rhs.append(var) - elif arg == "[Node]": - lines.append(var + " <- mapM top " + n) - rhs.append(var) - else: - rhs.append(n) - - space = "" - if lhs != []: - space = " " - newf.write(" " + name + space + " ".join(lhs) + " -> do\n") - for l in lines: - newf.write(" " + l + "\n") - newf.write(" return $ " + name + space + " ".join(rhs) + "\n") - newf.write(" _ -> next node\n") - -def main(): - f = open("Tree.hs") - newf = open("BaseTransforms.hs", "w") - - newf.write("""-- Base transforms --- Automatically generated from Tree.hs -- do not edit! - -module BaseTransforms where - -import qualified Tree as N -import Pass -import Control.Monad -""") - - while 1: - s = f.readline() - if s == "": - break - if s.startswith("-- {{{ BEGIN"): - ss = s.strip().split() - update_def(ss[3], f, newf) - f.close() - newf.close() - -main()