Turned csCurrentFile into a monad transformer variable, and added csCompilationHash to help in uniquifying names between files

Main.hs

@@ -400,7 +400,7 @@ compileFull inputFile moutputFile
 
     searchReadFile :: Meta -> String -> FilesPassM String
     searchReadFile m fn
-      = do (h, _) <- searchFile m fn
+      = do (h, _) <- searchFile m inputFile fn
            liftIO $ hGetContents h
            -- Don't use hClose because hGetContents is lazy
 

data/CompState.hs

@@ -143,8 +143,9 @@ data CompState = CompState {
     -- Extra include files, stored without the .tock.h suffix.
     csExtraIncludes :: [String],
 
-    -- Set by preprocessor
-    csCurrentFile :: String, -- Also used by some later passes!
+    -- A useful C-compatible hash value based on the original source file, used
+    -- as a unique ID during compilation
+    csCompilationHash :: String,
     -- #USEd files.  These are stored with any (known) extensions removed:
     csUsedFiles :: Set String,
 
@@ -212,7 +213,7 @@ emptyState = CompState {
     csExtraSizes = [],
     csExtraIncludes = [],
 
-    csCurrentFile = "none",
+    csCompilationHash = "",
     csUsedFiles = Set.empty,
 
     csMainLocals = [],
@@ -327,7 +328,7 @@ makeUniqueName m s
                      -- For #INCLUDEd files, they might be included twice, so we
                      -- still need the extra suffixes:
                      else do putCompState $ cs { csNameCounter = csNameCounter cs + 1 }
-                             return $ mungeMeta m ++ "u" ++ show (csNameCounter cs)
+                             return $ csCompilationHash cs ++ "u" ++ show (csNameCounter cs)
          return $ s ++ "_" ++ munged
 
 mungeMeta :: Meta -> String
@@ -494,10 +495,9 @@ specTypeOfName n
 
 -- | Open an included file, looking for it in the search path.
 -- Return the open filehandle and the location of the file.
-searchFile :: forall m. (Die m, CSMR m, MonadIO m) => Meta -> String -> m (Handle, String)
-searchFile m filename
+searchFile :: forall m. (Die m, CSMR m, MonadIO m) => Meta -> String -> String -> m (Handle, String)
+searchFile m currentFile filename
     =  do cs <- getCompState
-          let currentFile = csCurrentFile cs
           let possibilities = joinPath currentFile filename
                               : [dir ++ "/" ++ filename | dir <- (csSearchPath . csOpts) cs]
           openOneOf possibilities possibilities

frontends/PreprocessOccam.hs

@@ -21,7 +21,10 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module PreprocessOccam (preprocessOccamProgram, preprocessOccamSource,
                         preprocessOccam, expandIncludes) where
 
+import Control.Monad.Reader
 import Control.Monad.State
+import Data.HashTable (hashString)
+import Data.Int
 import Data.List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -41,30 +44,37 @@ import PrettyShow
 import StructureOccam
 import Utils
 
+type PreprocessM = ReaderT String PassM
+
 -- | Preprocess a file and return its tokenised form ready for parsing.
-preprocessFile :: Meta -> [String] -> String -> PassM [Token]
-preprocessFile m implicitMods filename
-    =  do (handle, realFilename) <- searchFile m filename
+preprocessFile :: Meta -> [String] -> (String, Bool) -> PreprocessM [Token]
+preprocessFile m implicitMods (filename, mainFile)
+    =  do prevFile <- ask
+          (handle, realFilename) <- searchFile m prevFile filename
           progress $ "Loading source file " ++ realFilename
-          origCS <- get
+          origCS <- getCompState
           let modFunc = if dropTockInc filename `Set.member` csUsedFiles origCS
                           then Set.insert (dropTockInc realFilename)
                                  . Set.delete (dropTockInc filename)
                           else id
-          modifyCompState (\cs -> cs { csCurrentFile = realFilename
-                                     , csUsedFiles = modFunc $ csUsedFiles cs })
           s <- liftIO $ hGetContents handle
-          toks <- preprocessSource m implicitMods realFilename s
-          modifyCompState (\cs -> cs { csCurrentFile = csCurrentFile origCS })
-          return toks
+          modifyCompState $ \cs -> cs { csUsedFiles = modFunc $ csUsedFiles cs }
+          when mainFile $
+            modifyCompState $ \cs -> cs { csCompilationHash = show $ makePosInteger $ hashString s}
+          local (const realFilename) $ preprocessSource m implicitMods realFilename s
+          
   where
     -- drops ".tock.inc" from the end if it's there:
     dropTockInc s
       | ".tock.inc" `isSuffixOf` s = reverse . drop (length ".tock.inc") . reverse $ s
       | otherwise = s
 
+    makePosInteger :: Int32 -> Integer
+    makePosInteger n = toInteger n + (toInteger (maxBound :: Int32))
+
+
 -- | Preprocesses source directly and returns its tokenised form ready for parsing.
-preprocessSource :: Meta -> [String] -> String -> String -> PassM [Token]
+preprocessSource :: Meta -> [String] -> String -> String -> PreprocessM [Token]
 preprocessSource m implicitMods realFilename s
     =  do toks <- runLexer realFilename $ removeASM s
           veryDebug $ "{{{ lexer tokens"
@@ -123,10 +133,10 @@ preprocessSource m implicitMods realFilename s
           | otherwise = curLine : removeASM' moreLines
 
 -- | Expand 'IncludeFile' markers in a token stream.
-expandIncludes :: [Token] -> PassM [Token]
+expandIncludes :: [Token] -> PreprocessM [Token]
 expandIncludes [] = return []
 expandIncludes (Token m (IncludeFile filename) : Token _ EndOfLine : ts)
-    =  do contents <- preprocessFile m [] filename
+    =  do contents <- preprocessFile m [] (filename, False)
           rest <- expandIncludes ts
           return $ contents ++ rest
 expandIncludes (Token m (IncludeFile _) : _)
@@ -134,7 +144,7 @@ expandIncludes (Token m (IncludeFile _) : _)
 expandIncludes (t:ts) = expandIncludes ts >>* (t :)
 
 -- | Preprocess a token stream.
-preprocessOccam :: [Token] -> PassM [Token]
+preprocessOccam :: [Token] -> PreprocessM [Token]
 preprocessOccam [] = return []
 preprocessOccam (Token m (TokPreprocessor s) : ts)
     = handleDirective m (stripPrefix s) ts >>= preprocessOccam
@@ -162,15 +172,15 @@ preprocessOccam (t:ts)
           return $ t : rest
 
 --{{{  preprocessor directive handlers
-type DirectiveFunc = Meta -> [String] -> PassM ([Token] -> PassM [Token])
+type DirectiveFunc = Meta -> [String] -> PreprocessM ([Token] -> PreprocessM [Token])
 
 -- | Call the handler for a preprocessor directive.
-handleDirective :: Meta -> String -> [Token] -> PassM [Token]
+handleDirective :: Meta -> String -> [Token] -> PreprocessM [Token]
 handleDirective m s x
   = do f <- lookup s directives
        f x
   where
-    lookup :: String -> [(Regex, DirectiveFunc)] -> PassM ([Token] -> PassM [Token])
+    lookup :: String -> [(Regex, DirectiveFunc)] -> PreprocessM ([Token] -> PreprocessM [Token])
     -- FIXME: This should really be an error rather than a warning, but
     -- currently we support so few preprocessor directives that this is more
     -- useful.
@@ -261,7 +271,7 @@ handleIf m [condition]
     =  do b <- runPreprocParser m expression condition
           return $ skipCondition b 0
   where
-    skipCondition :: Bool -> Int -> [Token] -> PassM [Token]
+    skipCondition :: Bool -> Int -> [Token] -> PreprocessM [Token]
     skipCondition _ _ [] = dieP m "Couldn't find a matching #ENDIF"
 
     -- At level 0, we flip state on ELSE and finish on ENDIF.
@@ -280,7 +290,7 @@ handleIf m [condition]
     -- And otherwise we copy through tokens if the condition's true.
     skipCondition b n (t:ts) = copyThrough b n t ts
 
-    copyThrough :: Bool -> Int -> Token -> [Token] -> PassM [Token]
+    copyThrough :: Bool -> Int -> Token -> [Token] -> PreprocessM [Token]
     copyThrough True n t ts = skipCondition True n ts >>* (t :)
     copyThrough False n _ ts = skipCondition False n ts
 --}}}
@@ -406,7 +416,7 @@ expression
     <?> "preprocessor complex expression"
 
 -- | Match a 'PreprocParser' production.
-runPreprocParser :: Meta -> PreprocParser a -> String -> PassM a
+runPreprocParser :: Meta -> PreprocParser a -> String -> PreprocessM a
 runPreprocParser m prod s
     =  do st <- getCompState >>* csOpts
           case runParser wrappedProd (csDefinitions st) (show m) s of
@@ -424,9 +434,7 @@ runPreprocParser m prod s
 preprocessOccamProgram :: String -> PassM [Token]
 preprocessOccamProgram filename
     =  do mods <- getCompState >>* (csImplicitModules . csOpts)
-          toks <- preprocessFile emptyMeta mods filename
-          -- Leave the main file name in the csCurrentFile slot:
-          modifyCompState $ \cs -> cs { csCurrentFile = filename }
+          toks <- runReaderT (preprocessFile emptyMeta mods (filename, True)) filename
           veryDebug $ "{{{ tokenised source"
           veryDebug $ pshow toks
           veryDebug $ "}}}"
@@ -434,4 +442,5 @@ preprocessOccamProgram filename
 
 -- | Preprocesses occam source direct from the given String
 preprocessOccamSource :: String -> PassM [Token]
-preprocessOccamSource source = preprocessSource emptyMeta [] "<unknown>" source
+preprocessOccamSource source
+  = runReaderT (preprocessSource emptyMeta [] "<unknown>" source) ""

frontends/StructureOccam.hs

@@ -36,7 +36,7 @@ continuationWords
 
 -- | Given the output of the lexer for a single file, add `Indent`, `Outdent`
 -- and `EndOfLine` markers.
-structureOccam :: [Token] -> PassM [Token]
+structureOccam :: forall m. Die m => [Token] -> m [Token]
 structureOccam [] = return []
 structureOccam ts = analyse 1 firstLine ts (Token emptyMeta EndOfLine)
   where
@@ -44,7 +44,7 @@ structureOccam ts = analyse 1 firstLine ts (Token emptyMeta EndOfLine)
     firstLine
         = case ts of ((Token m _):_) -> metaLine m
 
-    analyse :: Int -> Int -> [Token] -> Token -> PassM [Token]
+    analyse :: Int -> Int -> [Token] -> Token -> m [Token]
     -- Add extra EndOfLine at the end of the file.
     analyse prevCol _ [] _ = return $ Token emptyMeta EndOfLine : out
       where out = replicate (prevCol `div` 2) (Token emptyMeta Outdent)
@@ -66,7 +66,7 @@ structureOccam ts = analyse 1 firstLine ts (Token emptyMeta EndOfLine)
                            _ -> False
 
         -- A new line -- look to see what's going on with the indentation.
-        newLine :: [Token] -> PassM [Token]
+        newLine :: [Token] -> m [Token]
         newLine rest
           | col == prevCol + 2   = withEOL $ Token m Indent : rest
           -- FIXME: If col > prevCol, then look to see if there's a VALOF
@@ -79,7 +79,7 @@ structureOccam ts = analyse 1 firstLine ts (Token emptyMeta EndOfLine)
           | otherwise            = bad
             where
               steps = (prevCol - col) `div` 2
-              bad :: PassM [Token]
+              bad :: m [Token]
               bad = dieP m "Invalid indentation"
               -- This is actually the position at which the new line starts
               -- rather than the end of the previous line.

pass/Pass.hs

@@ -20,6 +20,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module Pass where
 
 import Control.Monad.Error
+import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Writer
 import Data.Generics (Constr, Data)
@@ -74,6 +75,22 @@ instance CSM (StateT s PassM) where
 instance Die (StateT s PassM) where
   dieReport = lift . dieReport
 
+instance Warn (StateT s PassM) where
+  warnReport = lift . warnReport
+
+instance CSMR (ReaderT r PassM) where
+  getCompState = lift getCompState
+
+instance CSM (ReaderT r PassM) where
+  putCompState = lift . putCompState
+  modifyCompState = lift . modifyCompState
+
+instance Die (ReaderT r PassM) where
+  dieReport = lift . dieReport
+
+instance Warn (ReaderT r PassM) where
+  warnReport = lift . warnReport
+
 -- | The type of a pass function.
 -- This is as generic as possible. Passes are used on 'A.AST' in normal use,
 -- but for explicit descent and testing it's useful to be able to run them

transformations/SimplifyProcs.hs

@@ -180,9 +180,8 @@ flattenAssign = pass "Flatten assignment"
     assign m _ v m' e = return $ A.Assign m [v] (A.ExpressionList m' [e])
 
     makeCopyProcName :: A.Name -> PassM A.Name
-    makeCopyProcName n = do file <- getCompState >>* csCurrentFile
-                            let m = Meta (Just file) 0 0 
-                            return $ n {A.nameName = "copy_" ++ mungeMeta m ++ A.nameName n}
+    makeCopyProcName n = do hash <- getCompState >>* csCompilationHash
+                            return $ n {A.nameName = "copy_" ++ hash ++ A.nameName n}
 
     complexAssign :: Meta -> A.Type -> A.Variable -> Meta -> A.Expression -> PassM A.Process
     complexAssign m t v m' e