suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Wholesale rename: ParseState is now CompState

Browse Source
This commit is contained in:
Adam Sampson 2007-05-16 23:31:44 +00:00
parent e4125e768b
commit a75ac6a455
16 changed files with 172 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
fco2/ParseState.hs → fco2/CompState.hs
View File

@ -1,5 +1,5 @@
-- | Compiler state.
module ParseState where
module CompState where
import Data.Generics
import Data.Map (Map)
@ -11,151 +11,151 @@ import Errors
import Metadata
-- | State necessary for compilation.
data ParseState = ParseState {
data CompState = CompState {
-- Set by Main (from command-line options)
psVerboseLevel :: Int,
psParseOnly :: Bool,
psOutputFile :: String,
csVerboseLevel :: Int,
csParseOnly :: Bool,
csOutputFile :: String,
-- Set by preprocessor
psSourceFiles :: Map String String,
psIndentLinesIn :: [String],
psIndentLinesOut :: [String],
csSourceFiles :: Map String String,
csIndentLinesIn :: [String],
csIndentLinesOut :: [String],
-- Set by Parse
psLocalNames :: [(String, A.Name)],
psMainLocals :: [(String, A.Name)],
psNames :: Map String A.NameDef,
psNameCounter :: Int,
psTypeContext :: [Maybe A.Type],
psLoadedFiles :: [String],
psWarnings :: [String],
csLocalNames :: [(String, A.Name)],
csMainLocals :: [(String, A.Name)],
csNames :: Map String A.NameDef,
csNameCounter :: Int,
csTypeContext :: [Maybe A.Type],
csLoadedFiles :: [String],
csWarnings :: [String],
-- Set by passes
psNonceCounter :: Int,
psFunctionReturns :: Map String [A.Type],
psPulledItems :: [[A.Structured -> A.Structured]],
psAdditionalArgs :: Map String [A.Actual]
csNonceCounter :: Int,
csFunctionReturns :: Map String [A.Type],
csPulledItems :: [[A.Structured -> A.Structured]],
csAdditionalArgs :: Map String [A.Actual]
}
deriving (Show, Data, Typeable)
instance Show (A.Structured -> A.Structured) where
show p = "(function on Structured)"
emptyState :: ParseState
emptyState = ParseState {
psVerboseLevel = 0,
psParseOnly = False,
psOutputFile = "-",
emptyState :: CompState
emptyState = CompState {
csVerboseLevel = 0,
csParseOnly = False,
csOutputFile = "-",
psSourceFiles = Map.empty,
psIndentLinesIn = [],
psIndentLinesOut = [],
csSourceFiles = Map.empty,
csIndentLinesIn = [],
csIndentLinesOut = [],
psLocalNames = [],
psMainLocals = [],
psNames = Map.empty,
psNameCounter = 0,
psTypeContext = [],
psLoadedFiles = [],
psWarnings = [],
csLocalNames = [],
csMainLocals = [],
csNames = Map.empty,
csNameCounter = 0,
csTypeContext = [],
csLoadedFiles = [],
csWarnings = [],
psNonceCounter = 0,
psFunctionReturns = Map.empty,
psPulledItems = [],
psAdditionalArgs = Map.empty
csNonceCounter = 0,
csFunctionReturns = Map.empty,
csPulledItems = [],
csAdditionalArgs = Map.empty
}
-- | Class of monads which keep a ParseState.
-- | Class of monads which keep a CompState.
-- (This is just shorthand for the equivalent MonadState constraint.)
class MonadState ParseState m => PSM m
instance MonadState ParseState m => PSM m
class MonadState CompState m => CSM m
instance MonadState CompState m => CSM m
--{{{ name definitions
-- | Add the definition of a name.
defineName :: PSM m => A.Name -> A.NameDef -> m ()
defineName :: CSM m => A.Name -> A.NameDef -> m ()
defineName n nd
= modify $ (\ps -> ps { psNames = Map.insert (A.nameName n) nd (psNames ps) })
= modify $ (\ps -> ps { csNames = Map.insert (A.nameName n) nd (csNames ps) })
-- | Find the definition of a name.
lookupName :: (PSM m, Die m) => A.Name -> m A.NameDef
lookupName :: (CSM m, Die m) => A.Name -> m A.NameDef
lookupName n
= do ps <- get
case Map.lookup (A.nameName n) (psNames ps) of
case Map.lookup (A.nameName n) (csNames ps) of
Just nd -> return nd
Nothing -> die $ "cannot find name " ++ A.nameName n
--}}}
--{{{ warnings
-- | Add a warning.
addWarning :: PSM m => Meta -> String -> m ()
addWarning m s = modify (\ps -> ps { psWarnings = msg : psWarnings ps })
addWarning :: CSM m => Meta -> String -> m ()
addWarning m s = modify (\ps -> ps { csWarnings = msg : csWarnings ps })
where msg = "Warning: " ++ show m ++ ": " ++ s
--}}}
--{{{ pulled items
-- | Enter a pulled-items context.
pushPullContext :: PSM m => m ()
pushPullContext = modify (\ps -> ps { psPulledItems = [] : psPulledItems ps })
pushPullContext :: CSM m => m ()
pushPullContext = modify (\ps -> ps { csPulledItems = [] : csPulledItems ps })
-- | Leave a pulled-items context.
popPullContext :: PSM m => m ()
popPullContext = modify (\ps -> ps { psPulledItems = tail $ psPulledItems ps })
popPullContext :: CSM m => m ()
popPullContext = modify (\ps -> ps { csPulledItems = tail $ csPulledItems ps })
-- | Add a pulled item to the collection.
addPulled :: PSM m => (A.Structured -> A.Structured) -> m ()
addPulled :: CSM m => (A.Structured -> A.Structured) -> m ()
addPulled item
= modify (\ps -> case psPulledItems ps of
(l:ls) -> ps { psPulledItems = (item:l):ls })
= modify (\ps -> case csPulledItems ps of
(l:ls) -> ps { csPulledItems = (item:l):ls })
-- | Do we currently have any pulled items?
havePulled :: PSM m => m Bool
havePulled :: CSM m => m Bool
havePulled
= do ps <- get
case psPulledItems ps of
case csPulledItems ps of
([]:_) -> return False
_ -> return True
-- | Apply pulled items to a Structured.
applyPulled :: PSM m => A.Structured -> m A.Structured
applyPulled :: CSM m => A.Structured -> m A.Structured
applyPulled ast
= do ps <- get
case psPulledItems ps of
(l:ls) -> do put $ ps { psPulledItems = [] : ls }
case csPulledItems ps of
(l:ls) -> do put $ ps { csPulledItems = [] : ls }
return $ foldl (\p f -> f p) ast l
--}}}
--{{{ type contexts
-- | Enter a type context.
pushTypeContext :: PSM m => Maybe A.Type -> m ()
pushTypeContext :: CSM m => Maybe A.Type -> m ()
pushTypeContext t
= modify (\ps -> ps { psTypeContext = t : psTypeContext ps })
= modify (\ps -> ps { csTypeContext = t : csTypeContext ps })
-- | Leave a type context.
popTypeContext :: PSM m => m ()
popTypeContext :: CSM m => m ()
popTypeContext
= modify (\ps -> ps { psTypeContext = tail $ psTypeContext ps })
= modify (\ps -> ps { csTypeContext = tail $ csTypeContext ps })
-- | Get the current type context, if there is one.
getTypeContext :: PSM m => m (Maybe A.Type)
getTypeContext :: CSM m => m (Maybe A.Type)
getTypeContext
= do ps <- get
case psTypeContext ps of
case csTypeContext ps of
(Just c):_ -> return $ Just c
_ -> return Nothing
--}}}
--{{{ nonces
-- | Generate a throwaway unique name.
makeNonce :: PSM m => String -> m String
makeNonce :: CSM m => String -> m String
makeNonce s
= do ps <- get
let i = psNonceCounter ps
put ps { psNonceCounter = i + 1 }
let i = csNonceCounter ps
put ps { csNonceCounter = i + 1 }
return $ s ++ "_n" ++ show i
-- | Generate and define a nonce specification.
defineNonce :: PSM m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification
defineNonce :: CSM m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification
defineNonce m s st nt am
= do ns <- makeNonce s
let n = A.Name m A.ProcName ns
@ -172,22 +172,22 @@ defineNonce m s st nt am
return $ A.Specification m n st
-- | Generate and define a no-arg wrapper PROC around a process.
makeNonceProc :: PSM m => Meta -> A.Process -> m A.Specification
makeNonceProc :: CSM m => Meta -> A.Process -> m A.Specification
makeNonceProc m p
= defineNonce m "wrapper_proc" (A.Proc m A.PlainSpec [] p) A.ProcName A.Abbrev
-- | Generate and define a variable abbreviation.
makeNonceIs :: PSM m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification
makeNonceIs :: CSM m => String -> Meta -> A.Type -> A.AbbrevMode -> A.Variable -> m A.Specification
makeNonceIs s m t am v
= defineNonce m s (A.Is m am t v) A.VariableName am
-- | Generate and define an expression abbreviation.
makeNonceIsExpr :: PSM m => String -> Meta -> A.Type -> A.Expression -> m A.Specification
makeNonceIsExpr :: CSM m => String -> Meta -> A.Type -> A.Expression -> m A.Specification
makeNonceIsExpr s m t e
= defineNonce m s (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev
-- | Generate and define a variable.
makeNonceVariable :: PSM m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification
makeNonceVariable :: CSM m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification
makeNonceVariable s m t nt am
= defineNonce m s (A.Declaration m t) nt am
--}}}

10
fco2/EvalConstants.hs
View File

@ -14,16 +14,16 @@ import Numeric
import Text.Printf
import qualified AST as A
import CompState
import Errors
import EvalLiterals
import Metadata
import ParseState
import Pass
import Types
-- | Simplify an expression by constant folding, and also return whether it's a
-- constant after that.
constantFold :: PSM m => A.Expression -> m (A.Expression, Bool, String)
constantFold :: CSM m => A.Expression -> m (A.Expression, Bool, String)
constantFold e
= do ps <- get
let (e', msg) = case simplifyExpression ps e of
@ -32,7 +32,7 @@ constantFold e
return (e', isConstant e', msg)
-- | Is a name defined as a constant expression? If so, return its definition.
getConstantName :: (PSM m, Die m) => A.Name -> m (Maybe A.Expression)
getConstantName :: (CSM m, Die m) => A.Name -> m (Maybe A.Expression)
getConstantName n
= do st <- specTypeOfName n
case st of
@ -42,7 +42,7 @@ getConstantName n
_ -> return Nothing
-- | Is a name defined as a constant expression?
isConstantName :: (PSM m, Die m) => A.Name -> m Bool
isConstantName :: (CSM m, Die m) => A.Name -> m Bool
isConstantName n
= do me <- getConstantName n
return $ case me of
@ -51,7 +51,7 @@ isConstantName n
-- | Attempt to simplify an expression as far as possible by precomputing
-- constant bits.
simplifyExpression :: ParseState -> A.Expression -> Either String A.Expression
simplifyExpression :: CompState -> A.Expression -> Either String A.Expression
simplifyExpression ps e
= case runEvaluator ps (evalExpression e) of
Left err -> Left err

10
fco2/EvalLiterals.hs
View File

@ -13,10 +13,10 @@ import Data.Word
import Numeric
import qualified AST as A
import CompState
import Errors
import ParseState
type EvalM = ErrorT String (StateT ParseState Identity)
type EvalM = ErrorT String (StateT CompState Identity)
instance Die EvalM where
die = throwError
@ -52,7 +52,7 @@ isConstantArray (A.ArrayElemArray aes) = and $ map isConstantArray aes
isConstantArray (A.ArrayElemExpr e) = isConstant e
-- | Evaluate a constant integer expression.
evalIntExpression :: (PSM m, Die m) => A.Expression -> m Int
evalIntExpression :: (CSM m, Die m) => A.Expression -> m Int
evalIntExpression e
= do ps <- get
case runEvaluator ps (evalSimpleExpression e) of
@ -61,7 +61,7 @@ evalIntExpression e
Right _ -> die "expression is not of INT type"
-- | Evaluate a byte literal.
evalByte :: (PSM m, Die m) => String -> m Char
evalByte :: (CSM m, Die m) => String -> m Char
evalByte s
= do ps <- get
case runEvaluator ps (evalByteLiteral s) of
@ -69,7 +69,7 @@ evalByte s
Right (OccByte ch) -> return (chr $ fromIntegral ch)
-- | Run an evaluator operation.
runEvaluator :: ParseState -> EvalM OccValue -> Either String OccValue
runEvaluator :: CompState -> EvalM OccValue -> Either String OccValue
runEvaluator ps func
= runIdentity (evalStateT (runErrorT func) ps)

2
fco2/GenerateC.hs
View File

@ -11,10 +11,10 @@ import Numeric
import Text.Printf
import qualified AST as A
import CompState
import EvalConstants
import EvalLiterals
import Metadata
import ParseState
import Pass
import Errors
import TLP

26
fco2/Indentation.hs
View File

@ -7,12 +7,12 @@ import Control.Monad.State
import Data.List
import Text.Regex
import CompState
import Errors
import ParseState
import Pass
-- FIXME When this joins continuation lines, it should stash the details of
-- what it joined into ParseState so that error reporting later on can
-- what it joined into CompState so that error reporting later on can
-- reconstruct the original position.
indentMarker = "__indent"
@ -26,13 +26,13 @@ eolMarker = "__eol"
-- explicit markers.
removeIndentation :: String -> String -> PassM String
removeIndentation filename orig
= do modify $ (\ps -> ps { psIndentLinesIn = origLines,
psIndentLinesOut = [] })
= do modify $ (\ps -> ps { csIndentLinesIn = origLines,
csIndentLinesOut = [] })
catchError (nextLine 0) reportError
ps <- get
let out = concat $ intersperse "\n" $ reverse $ psIndentLinesOut ps
modify $ (\ps -> ps { psIndentLinesIn = [],
psIndentLinesOut = [] })
let out = concat $ intersperse "\n" $ reverse $ csIndentLinesOut ps
modify $ (\ps -> ps { csIndentLinesIn = [],
csIndentLinesOut = [] })
return out
where
origLines = lines orig
@ -41,29 +41,29 @@ removeIndentation filename orig
reportError :: String -> PassM ()
reportError error
= do ps <- get
let lineNumber = length origLines - length (psIndentLinesIn ps)
let lineNumber = length origLines - length (csIndentLinesIn ps)
die $ filename ++ ":" ++ show lineNumber ++ ": " ++ error
-- | Get the next raw line from the input.
getLine :: PassM (Maybe String)
getLine
= do ps <- get
case psIndentLinesIn ps of
case csIndentLinesIn ps of
[] -> return Nothing
(line:rest) ->
do put $ ps { psIndentLinesIn = rest }
do put $ ps { csIndentLinesIn = rest }
return $ Just line
-- | Add a line to the output.
putLine :: String -> PassM ()
putLine line
= modify $ (\ps -> ps { psIndentLinesOut = line : psIndentLinesOut ps })
= modify $ (\ps -> ps { csIndentLinesOut = line : csIndentLinesOut ps })
-- | Append to the *previous* line added.
addToLine :: String -> PassM ()
addToLine s
= modify $ (\ps -> ps { psIndentLinesOut =
case psIndentLinesOut ps of (l:ls) -> ((l ++ s):ls) })
= modify $ (\ps -> ps { csIndentLinesOut =
case csIndentLinesOut ps of (l:ls) -> ((l ++ s):ls) })
-- | Given a line, read the rest of it, then return the complete thing.
finishLine :: String -> String -> Bool -> Bool -> String -> PassM String

14
fco2/Main.hs
View File

@ -9,10 +9,10 @@ import System
import System.Console.GetOpt
import System.IO
import CompState
import Errors
import GenerateC
import Parse
import ParseState
import Pass
import PrettyShow
import SimplifyExprs
@ -28,7 +28,7 @@ passes =
, ("Flatten nested declarations", unnest)
]
type OptFunc = ParseState -> IO ParseState
type OptFunc = CompState -> IO CompState
options :: [OptDescr OptFunc]
options =
@ -38,13 +38,13 @@ options =
]
optParseOnly :: OptFunc
optParseOnly ps = return $ ps { psParseOnly = True }
optParseOnly ps = return $ ps { csParseOnly = True }
optVerbose :: OptFunc
optVerbose ps = return $ ps { psVerboseLevel = psVerboseLevel ps + 1 }
optVerbose ps = return $ ps { csVerboseLevel = csVerboseLevel ps + 1 }
optOutput :: String -> OptFunc
optOutput s ps = return $ ps { psOutputFile = s }
optOutput s ps = return $ ps { csOutputFile = s }
getOpts :: [String] -> IO ([OptFunc], [String])
getOpts argv =
@ -90,7 +90,7 @@ compile fn
showWarnings
output <-
if psParseOnly optsPS
if csParseOnly optsPS
then return $ show ast1
else
do progress "Passes:"
@ -105,7 +105,7 @@ compile fn
showWarnings
case psOutputFile optsPS of
case csOutputFile optsPS of
"-" -> liftIO $ putStr output
file ->
do progress $ "Writing output file " ++ file

2
fco2/Makefile
View File

@ -4,6 +4,7 @@ all: $(targets)
sources = \
AST.hs \
CompState.hs \
Errors.hs \
EvalConstants.hs \
EvalLiterals.hs \
@ -13,7 +14,6 @@ sources = \
Main.hs \
Metadata.hs \
Parse.hs \
ParseState.hs \
Pass.hs \
PrettyShow.hs \
SimplifyExprs.hs \

38
fco2/Parse.hs
View File

@ -16,19 +16,19 @@ import qualified Text.ParserCombinators.Parsec.Token as P
import Text.Regex
import qualified AST as A
import CompState
import Errors
import EvalConstants
import EvalLiterals
import Indentation
import Intrinsics
import Metadata
import ParseState
import Pass
import Types
import Utils
--{{{ setup stuff for Parsec
type OccParser = GenParser Char ParseState
type OccParser = GenParser Char CompState
-- | Make MonadState functions work in the parser monad.
-- This came from <http://hackage.haskell.org/trac/ghc/ticket/1274> -- which means
@ -145,7 +145,7 @@ occamStyle
, P.caseSensitive = True
}
lexer :: P.TokenParser ParseState
lexer :: P.TokenParser CompState
lexer = P.makeTokenParser occamStyle
-- XXX replace whitespace with something that doesn't eat \ns
@ -498,7 +498,7 @@ noTypeContext = inTypeContext Nothing
findName :: A.Name -> OccParser A.Name
findName thisN
= do st <- getState
origN <- case lookup (A.nameName thisN) (psLocalNames st) of
origN <- case lookup (A.nameName thisN) (csLocalNames st) of
Nothing -> fail $ "name " ++ A.nameName thisN ++ " not defined"
Just n -> return n
if A.nameType thisN /= A.nameType origN
@ -508,7 +508,7 @@ findName thisN
scopeIn :: A.Name -> A.SpecType -> A.AbbrevMode -> OccParser A.Name
scopeIn n@(A.Name m nt s) t am
= do st <- getState
let s' = s ++ "_u" ++ (show $ psNameCounter st)
let s' = s ++ "_u" ++ (show $ csNameCounter st)
let n' = n { A.nameName = s' }
let nd = A.NameDef {
A.ndMeta = m,
@ -521,18 +521,18 @@ scopeIn n@(A.Name m nt s) t am
}
defineName n' nd
modify $ (\st -> st {
psNameCounter = (psNameCounter st) + 1,
psLocalNames = (s, n') : (psLocalNames st)
csNameCounter = (csNameCounter st) + 1,
csLocalNames = (s, n') : (csLocalNames st)
})
return n'
scopeOut :: A.Name -> OccParser ()
scopeOut n@(A.Name m nt s)
= do st <- getState
let lns' = case psLocalNames st of
let lns' = case csLocalNames st of
(s, _):ns -> ns
otherwise -> dieInternal "scopeOut trying to scope out the wrong name"
setState $ st { psLocalNames = lns' }
setState $ st { csLocalNames = lns' }
-- FIXME: Do these with generics? (going carefully to avoid nested code blocks)
scopeInRep :: A.Replicator -> OccParser A.Replicator
@ -2031,7 +2031,7 @@ ppUse
-- Check whether it's been included already.
ps <- getState
if file `elem` psLoadedFiles ps
if file `elem` csLoadedFiles ps
then process
else includeFile file
<?> "#USE directive"
@ -2046,7 +2046,7 @@ includeFile file
do setState ps'
return p
Right f ->
do setState ps' { psLocalNames = psMainLocals ps' }
do setState ps' { csLocalNames = csMainLocals ps' }
p <- process
return $ f p
@ -2067,7 +2067,7 @@ mainProcess
-- Stash the current locals so that we can either restore them
-- when we get back to the file we included this one from, or
-- pull the TLP name from them at the end.
updateState $ (\ps -> ps { psMainLocals = psLocalNames ps })
updateState $ (\ps -> ps { csMainLocals = csLocalNames ps })
return $ A.Main m
--}}}
--}}}
@ -2076,7 +2076,7 @@ mainProcess
-- This is only really true once we've tacked a process onto the bottom; a
-- source file is really a series of specifications, but the later ones need to
-- have the earlier ones in scope, so we can't parse them separately.
sourceFile :: OccParser (A.Process, ParseState)
sourceFile :: OccParser (A.Process, CompState)
sourceFile
= do whiteSpace
p <- process
@ -2087,7 +2087,7 @@ sourceFile
-- applied to a process (which we return as a function). This is likewise a bit
-- of a cheat, in that included files should really be *textually* included,
-- but it's good enough for most reasonable uses.
includedFile :: OccParser (Either A.Process (A.Process -> A.Process), ParseState)
includedFile :: OccParser (Either A.Process (A.Process -> A.Process), CompState)
includedFile
= do whiteSpace
p <- process
@ -2140,7 +2140,7 @@ loadSource file = load file file
load :: String -> String -> PassM ()
load file realName
= do ps <- get
case Map.lookup file (psSourceFiles ps) of
case Map.lookup file (csSourceFiles ps) of
Just _ -> return ()
Nothing ->
do progress $ "Loading source file " ++ realName
@ -2148,7 +2148,7 @@ loadSource file = load file file
source <- removeIndentation realName (rawSource ++ "\n" ++ mainMarker ++ "\n")
debug $ "Preprocessed source:"
debug $ numberLines source
modify $ (\ps -> ps { psSourceFiles = Map.insert file source (psSourceFiles ps) })
modify $ (\ps -> ps { csSourceFiles = Map.insert file source (csSourceFiles ps) })
let deps = map mangleModName $ preFindIncludes source
sequence_ [load dep (joinPath realName dep) | dep <- deps]
--}}}
@ -2161,12 +2161,12 @@ testParse prod text
putStrLn $ "Result: " ++ show r
-- | Parse a file with the given production.
parseFile :: Monad m => String -> OccParser t -> ParseState -> m t
parseFile :: Monad m => String -> OccParser t -> CompState -> m t
parseFile file prod ps
= do let source = case Map.lookup file (psSourceFiles ps) of
= do let source = case Map.lookup file (csSourceFiles ps) of
Just s -> s
Nothing -> dieIO $ "Failed to preload file: " ++ show file
let ps' = ps { psLoadedFiles = file : psLoadedFiles ps }
let ps' = ps { csLoadedFiles = file : csLoadedFiles ps }
case runParser prod ps' file source of
Left err -> dieIO $ "Parse error: " ++ show err
Right r -> return r

24
fco2/Pass.hs
View File

@ -8,13 +8,13 @@ import Data.List
import System.IO
import qualified AST as A
import CompState
import Errors
import Metadata
import ParseState
import PrettyShow
-- | The monad in which AST-mangling passes operate.
type PassM = ErrorT String (StateT ParseState IO)
type PassM = ErrorT String (StateT CompState IO)
instance Die PassM where
die = throwError
@ -34,37 +34,37 @@ runPasses ((s, p):ps) ast
runPasses ps ast'
-- | Print a message if above the given verbosity level.
verboseMessage :: (PSM m, MonadIO m) => Int -> String -> m ()
verboseMessage :: (CSM m, MonadIO m) => Int -> String -> m ()
verboseMessage n s
= do ps <- get
when (psVerboseLevel ps >= n) $
when (csVerboseLevel ps >= n) $
liftIO $ hPutStrLn stderr s
-- | Print a warning message.
warn :: (PSM m, MonadIO m) => String -> m ()
warn :: (CSM m, MonadIO m) => String -> m ()
warn = verboseMessage 0
-- | Print out any warnings stored.
showWarnings :: (PSM m, MonadIO m) => m ()
showWarnings :: (CSM m, MonadIO m) => m ()
showWarnings
= do ps <- get
sequence_ $ map warn (reverse $ psWarnings ps)
put $ ps { psWarnings = [] }
sequence_ $ map warn (reverse $ csWarnings ps)
put $ ps { csWarnings = [] }
-- | Print a progress message.
progress :: (PSM m, MonadIO m) => String -> m ()
progress :: (CSM m, MonadIO m) => String -> m ()
progress = verboseMessage 1
-- | Print a debugging message.
debug :: (PSM m, MonadIO m) => String -> m ()
debug :: (CSM m, MonadIO m) => String -> m ()
debug = verboseMessage 2
-- | Print a really verbose debugging message.
veryDebug :: (PSM m, MonadIO m) => String -> m ()
veryDebug :: (CSM m, MonadIO m) => String -> m ()
veryDebug = verboseMessage 3
-- | Dump the AST and parse state.
debugAST :: (PSM m, MonadIO m) => A.Process -> m ()
debugAST :: (CSM m, MonadIO m) => A.Process -> m ()
debugAST p
= do veryDebug $ "{{{ AST"
veryDebug $ pshow p

6
fco2/SimplifyExprs.hs
View File

@ -7,9 +7,9 @@ import qualified Data.Map as Map
import Data.Maybe
import qualified AST as A
import CompState
import Errors
import Metadata
import ParseState
import Types
import Pass
@ -36,7 +36,7 @@ functionsToProcs = doGeneric `extM` doSpecification
specs <- sequence [makeNonceVariable "return_formal" mf t A.VariableName A.Abbrev | t <- rts]
let names = [n | A.Specification mf n _ <- specs]
-- Note the return types so we can fix calls later.
modify $ (\ps -> ps { psFunctionReturns = Map.insert (A.nameName n) rts (psFunctionReturns ps) })
modify $ (\ps -> ps { csFunctionReturns = Map.insert (A.nameName n) rts (csFunctionReturns ps) })
-- Turn the value process into an assignment process.
let p = A.Seq mf $ vpToSeq vp [A.Variable mf n | n <- names]
let st = A.Proc mf sm (fs ++ [A.Formal A.Abbrev t n | (t, n) <- zip rts names]) p
@ -210,7 +210,7 @@ pullUp = doGeneric
ets <- sequence [typeOfExpression e | e <- es']
ps <- get
rts <- Map.lookup (A.nameName n) (psFunctionReturns ps)
rts <- Map.lookup (A.nameName n) (csFunctionReturns ps)
specs <- sequence [makeNonceVariable "return_actual" m t A.VariableName A.Original | t <- rts]
sequence_ [addPulled $ A.Spec m spec | spec <- specs]

2
fco2/SimplifyProcs.hs
View File

@ -7,8 +7,8 @@ import qualified Data.Map as Map
import Data.Maybe
import qualified AST as A
import CompState
import Metadata
import ParseState
import Types
import Pass

2
fco2/SimplifyTypes.hs
View File

@ -27,7 +27,7 @@ resolveNamedTypes = doGeneric `extM` doType
doType t@(A.UserDataType _) = underlyingType t
doType t = doGeneric t
-- | Resolve named types in ParseState.
-- | Resolve named types in CompState.
rntState :: A.Process -> PassM A.Process
rntState p
= do st <- get

8
fco2/TLP.hs
View File

@ -8,9 +8,9 @@ import Data.List
import Data.Maybe
import qualified AST as A
import CompState
import Errors
import Metadata
import ParseState
import Types
data TLPChannel = TLPIn | TLPOut | TLPError
@ -18,10 +18,10 @@ data TLPChannel = TLPIn | TLPOut | TLPError
-- | Get the name of the TLP and the channels it uses.
-- Fail if the process isn't using a valid interface.
tlpInterface :: (PSM m, Die m) => m (A.Name, [TLPChannel])
tlpInterface :: (CSM m, Die m) => m (A.Name, [TLPChannel])
tlpInterface
= do ps <- get
let mainName = snd $ head $ psMainLocals ps
let mainName = snd $ head $ csMainLocals ps
st <- specTypeOfName mainName
formals <- case st of
A.Proc _ _ fs _ -> return fs
@ -30,7 +30,7 @@ tlpInterface
when ((nub chans) /= chans) $ die "Channels used more than once in TLP"
return (mainName, chans)
where
tlpChannel :: (PSM m, Die m) => A.Formal -> m TLPChannel
tlpChannel :: (CSM m, Die m) => A.Formal -> m TLPChannel
tlpChannel (A.Formal _ (A.Chan A.Byte) n)
= do def <- lookupName n
let origN = A.ndOrigName def

3
fco2/TODO
View File

@ -10,9 +10,6 @@ that takes several expressions.
(Multi-subscript expressions like a[x][y] currently get pulled up into an array
slice, which is inefficient.)
ParseState should be called something more sensible, since most of it has
nothing to do with parsing.
Eventually (not yet), channel formals should take a direction; this should
either be given directly using decorators, or inferred from the code that uses
them.

46
fco2/Types.hs
View File

@ -11,21 +11,21 @@ import Data.Maybe
import Debug.Trace
import qualified AST as A
import CompState
import Errors
import EvalLiterals
import Intrinsics
import ParseState
import Metadata
specTypeOfName :: (PSM m, Die m) => A.Name -> m A.SpecType
specTypeOfName :: (CSM m, Die m) => A.Name -> m A.SpecType
specTypeOfName n
= liftM A.ndType (lookupName n)
abbrevModeOfName :: (PSM m, Die m) => A.Name -> m A.AbbrevMode
abbrevModeOfName :: (CSM m, Die m) => A.Name -> m A.AbbrevMode
abbrevModeOfName n
= liftM A.ndAbbrevMode (lookupName n)
typeOfName :: (PSM m, Die m) => A.Name -> m A.Type
typeOfName :: (CSM m, Die m) => A.Name -> m A.Type
typeOfName n
= do st <- specTypeOfName n
case st of
@ -39,7 +39,7 @@ typeOfName n
--{{{ identifying types
-- | Apply a slice to a type.
sliceType :: (PSM m, Die m) => Meta -> A.Expression -> A.Expression -> A.Type -> m A.Type
sliceType :: (CSM m, Die m) => Meta -> A.Expression -> A.Expression -> A.Type -> m A.Type
sliceType m base count (A.Array (d:ds) t)
= case (isConstant base, isConstant count) of
(True, True) ->
@ -60,7 +60,7 @@ sliceType m base count (A.Array (d:ds) t)
sliceType m _ _ _ = dieP m "slice of non-array type"
-- | Get the fields of a record type.
recordFields :: (PSM m, Die m) => Meta -> A.Type -> m [(A.Name, A.Type)]
recordFields :: (CSM m, Die m) => Meta -> A.Type -> m [(A.Name, A.Type)]
recordFields m (A.Record rec)
= do st <- specTypeOfName rec
case st of
@ -69,13 +69,13 @@ recordFields m (A.Record rec)
recordFields m _ = dieP m "not record type"
-- | Get the type of a record field.
typeOfRecordField :: (PSM m, Die m) => Meta -> A.Type -> A.Name -> m A.Type
typeOfRecordField :: (CSM m, Die m) => Meta -> A.Type -> A.Name -> m A.Type
typeOfRecordField m t field
= do fs <- recordFields m t
checkJust "unknown record field" $ lookup field fs
-- | Apply a plain subscript to a type.
plainSubscriptType :: (PSM m, Die m) => Meta -> A.Expression -> A.Type -> m A.Type
plainSubscriptType :: (CSM m, Die m) => Meta -> A.Expression -> A.Type -> m A.Type
plainSubscriptType m sub (A.Array (d:ds) t)
= case (isConstant sub, d) of
(True, A.Dimension size) ->
@ -92,7 +92,7 @@ plainSubscriptType m _ t = dieP m $ "subscript of non-array type " ++ show t
-- | Apply a subscript to a type, and return what the type is after it's been
-- subscripted.
subscriptType :: (PSM m, Die m) => A.Subscript -> A.Type -> m A.Type
subscriptType :: (CSM m, Die m) => A.Subscript -> A.Type -> m A.Type
subscriptType sub t@(A.UserDataType _)
= resolveUserType t >>= subscriptType sub
subscriptType (A.SubscriptFromFor m base count) t
@ -113,7 +113,7 @@ subscriptType _ t = die $ "unsubscriptable type: " ++ show t
-- | The inverse of 'subscriptType': given a type that we know is the result of
-- a subscript, return what the type being subscripted is.
unsubscriptType :: (PSM m, Die m) => A.Subscript -> A.Type -> m A.Type
unsubscriptType :: (CSM m, Die m) => A.Subscript -> A.Type -> m A.Type
unsubscriptType (A.SubscriptFromFor _ _ _) t
= return $ removeFixedDimension t
unsubscriptType (A.SubscriptFrom _ _) t
@ -134,13 +134,13 @@ trivialSubscriptType (A.Array [d] t) = return t
trivialSubscriptType (A.Array (d:ds) t) = return $ A.Array ds t
trivialSubscriptType t = die $ "not plain array type: " ++ show t
typeOfVariable :: (PSM m, Die m) => A.Variable -> m A.Type
typeOfVariable :: (CSM m, Die m) => A.Variable -> m A.Type
typeOfVariable (A.Variable m n) = typeOfName n
typeOfVariable (A.SubscriptedVariable m s v)
= typeOfVariable v >>= subscriptType s
-- | Get the abbreviation mode of a variable.
abbrevModeOfVariable :: (PSM m, Die m) => A.Variable -> m A.AbbrevMode
abbrevModeOfVariable :: (CSM m, Die m) => A.Variable -> m A.AbbrevMode
abbrevModeOfVariable (A.Variable _ n) = abbrevModeOfName n
abbrevModeOfVariable (A.SubscriptedVariable _ sub v) = abbrevModeOfVariable v
@ -154,7 +154,7 @@ dyadicIsBoolean A.MoreEq = True
dyadicIsBoolean A.After = True
dyadicIsBoolean _ = False
typeOfExpression :: (PSM m, Die m) => A.Expression -> m A.Type
typeOfExpression :: (CSM m, Die m) => A.Expression -> m A.Type
typeOfExpression e
= case e of
A.Monadic m op e -> typeOfExpression e
@ -179,7 +179,7 @@ typeOfExpression e
A.OffsetOf m t n -> return A.Int
--}}}
returnTypesOfFunction :: (PSM m, Die m) => A.Name -> m [A.Type]
returnTypesOfFunction :: (CSM m, Die m) => A.Name -> m [A.Type]
returnTypesOfFunction n
= do st <- specTypeOfName n
case st of
@ -188,9 +188,9 @@ returnTypesOfFunction n
_ ->
do ps <- get
checkJust "not defined as a function" $
Map.lookup (A.nameName n) (psFunctionReturns ps)
Map.lookup (A.nameName n) (csFunctionReturns ps)
returnTypesOfIntrinsic :: (PSM m, Die m) => String -> m [A.Type]
returnTypesOfIntrinsic :: (CSM m, Die m) => String -> m [A.Type]
returnTypesOfIntrinsic s
= case lookup s intrinsicFunctions of
Just (rts, _) -> return rts
@ -198,7 +198,7 @@ returnTypesOfIntrinsic s
-- | Get the items in a channel's protocol (for typechecking).
-- Returns Left if it's a simple protocol, Right if it's tagged.
protocolItems :: (PSM m, Die m) => A.Variable -> m (Either [A.Type] [(A.Name, [A.Type])])
protocolItems :: (CSM m, Die m) => A.Variable -> m (Either [A.Type] [(A.Name, [A.Type])])
protocolItems v
= do A.Chan t <- typeOfVariable v
case t of
@ -221,7 +221,7 @@ abbrevModeOfSpec s
-- | Resolve a datatype into its underlying type -- i.e. if it's a named data
-- type, then return the underlying real type. This will recurse.
underlyingType :: (PSM m, Die m) => A.Type -> m A.Type
underlyingType :: (CSM m, Die m) => A.Type -> m A.Type
underlyingType t@(A.UserDataType _)
= resolveUserType t >>= underlyingType
underlyingType (A.Array ds t) = liftM (A.Array ds) (underlyingType t)
@ -230,7 +230,7 @@ underlyingType t = return t
-- | Like underlyingType, but only do the "outer layer": if you give this a
-- user type that's an array of user types, then you'll get back an array of
-- user types.
resolveUserType :: (PSM m, Die m) => A.Type -> m A.Type
resolveUserType :: (CSM m, Die m) => A.Type -> m A.Type
resolveUserType (A.UserDataType n)
= do st <- specTypeOfName n
case st of
@ -339,7 +339,7 @@ isCaseableType t = isIntegerType t
--{{{ simplifying and comparing types
-- | Simplify a type as far as possible: resolve data type aliases to their
-- real types, and remove non-constant array dimensions.
simplifyType :: (PSM m, Die m) => A.Type -> m A.Type
simplifyType :: (CSM m, Die m) => A.Type -> m A.Type
simplifyType origT@(A.Record n)
= do st <- specTypeOfName n
case st of
@ -369,7 +369,7 @@ data BytesInResult =
deriving (Show, Eq)
-- | Return the size in bytes of a data type.
bytesInType :: (PSM m, Die m) => A.Type -> m BytesInResult
bytesInType :: (CSM m, Die m) => A.Type -> m BytesInResult
bytesInType A.Byte = return $ BIJust 1
-- FIXME This is tied to the backend we're using (as is the constant folder).
bytesInType A.Int = return $ BIJust 4
@ -380,7 +380,7 @@ bytesInType A.Real32 = return $ BIJust 4
bytesInType A.Real64 = return $ BIJust 8
bytesInType a@(A.Array _ _) = bytesInArray 0 a
where
bytesInArray :: (PSM m, Die m) => Int -> A.Type -> m BytesInResult
bytesInArray :: (CSM m, Die m) => Int -> A.Type -> m BytesInResult
bytesInArray num (A.Array [] t) = bytesInType t
bytesInArray num (A.Array (d:ds) t)
= do ts <- bytesInArray (num + 1) (A.Array ds t)
@ -398,7 +398,7 @@ bytesInType (A.Record n)
(A.RecordType _ True nts) -> bytesInList nts
_ -> return $ BIUnknown
where
bytesInList :: (PSM m, Die m) => [(A.Name, A.Type)] -> m BytesInResult
bytesInList :: (CSM m, Die m) => [(A.Name, A.Type)] -> m BytesInResult
bytesInList [] = return $ BIJust 0
bytesInList ((_, t):rest)
= do bi <- bytesInType t

8
fco2/Unnest.hs
View File

@ -7,9 +7,9 @@ import qualified Data.Map as Map
import Data.Maybe
import qualified AST as A
import CompState
import EvalConstants
import Metadata
import ParseState
import Pass
import Types
@ -93,7 +93,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
-- we know it's not going to be moved by removeNesting, so anything
-- that it had in scope originally will still be in scope.
ps <- get
let isTLP = (snd $ head $ psMainLocals ps) == n
let isTLP = (snd $ head $ csMainLocals ps) == n
-- Figure out the free names.
let freeNames' = if isTLP then [] else Map.elems $ freeNamesIn st'
@ -136,7 +136,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
| (am, n, t) <- zip3 ams freeNames types]
debug $ "removeFreeNames: " ++ show n ++ " has new args " ++ show newAs
when (newAs /= []) $
modify $ (\ps -> ps { psAdditionalArgs = Map.insert (A.nameName n) newAs (psAdditionalArgs ps) })
modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) })
return spec'
_ -> doGeneric spec
@ -145,7 +145,7 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
doProcess :: A.Process -> PassM A.Process
doProcess p@(A.ProcCall m n as)
= do st <- get
case Map.lookup (A.nameName n) (psAdditionalArgs st) of
case Map.lookup (A.nameName n) (csAdditionalArgs st) of
Just add -> doGeneric $ A.ProcCall m n (as ++ add)
Nothing -> doGeneric p
doProcess p = doGeneric p