Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Localise module maps #286

Merged
merged 12 commits into from
Sep 4, 2024
5 changes: 5 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,8 @@
### 0.16.0 (2024)
* Added `--show-make-list` option
* Some robustness improvements around mod files [#286](https://github.com/camfort/fortran-src/pull/286)
* Helpers to work with the partial evaluation representation [#285](https://github.com/camfort/fortran-src/pull/285)

### 0.15.1 (Jun 22, 2023)
* remove unused vector-sized dependency

Expand Down
20 changes: 17 additions & 3 deletions app/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,11 +50,16 @@ import qualified Language.Fortran.Parser.Free.Lexer as Free
programName :: String
programName = "fortran-src"

showVersion :: String
showVersion = "0.16.0"

main :: IO ()
main = do
args <- getArgs
(opts, parsedArgs) <- compileArgs args
case (parsedArgs, action opts) of
(paths, ShowMyVersion) -> do
putStrLn $ "fortran-src version: " ++ showVersion
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

(We should have a release guide that instructs updating the version string shown here. I'll start a wiki page later.)

(paths, ShowMakeGraph) -> do
paths' <- expandDirs paths
mg <- genModGraph (fortranVersion opts) (includeDirs opts) (cppOptions opts) paths'
Expand Down Expand Up @@ -217,8 +222,12 @@ compileFileToMod mvers mods path moutfile = do
mmap = combinedModuleMap mods
tenv = combinedTypeEnv mods
runCompile = genModFile . fst . analyseTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis
parsedPF = fromRight' $ (Parser.byVerWithMods mods version) path contents
mod = runCompile parsedPF
parsedPF <-
case (Parser.byVerWithMods mods version) path contents of
Right pf -> return pf
Left err -> do
fail $ "Error parsing " ++ path ++ ": " ++ show err
let mod = runCompile parsedPF
fspath = path -<.> modFileSuffix `fromMaybe` moutfile
LB.writeFile fspath $ encodeModFile [mod]
return mod
Expand Down Expand Up @@ -301,6 +310,7 @@ printTypeErrors = putStrLn . showTypeErrors
data Action
= Lex | Parse | Typecheck | Rename | BBlocks | SuperGraph | Reprint | DumpModFile | Compile
| ShowFlows Bool Bool Int | ShowBlocks (Maybe Int) | ShowMakeGraph | ShowMakeList | Make
| ShowMyVersion
deriving Eq

instance Read Action where
Expand Down Expand Up @@ -329,7 +339,11 @@ initOptions = Options Nothing Parse Default Nothing [] Nothing False

options :: [OptDescr (Options -> Options)]
options =
[ Option ['v','F']
[ Option []
["version"]
(NoArg $ \ opts -> opts { action = ShowMyVersion })
"show fortran-src version"
, Option ['v','F']
["fortranVersion"]
(ReqArg (\v opts -> opts { fortranVersion = selectFortranVersion v }) "VERSION")
"Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]"
Expand Down
5 changes: 3 additions & 2 deletions fortran-src.cabal
Original file line number Diff line number Diff line change
@@ -1,11 +1,11 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.35.2.
-- This file has been generated from package.yaml by hpack version 0.36.0.
--
-- see: https://github.com/sol/hpack

name: fortran-src
version: 0.15.1
version: 0.16.0
synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial).
description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @<https://hackage.haskell.org/package/camfort CamFort>@ project, which uses fortran-src as its front end.
category: Language
Expand Down Expand Up @@ -280,6 +280,7 @@ test-suite spec
other-modules:
Language.Fortran.Analysis.BBlocksSpec
Language.Fortran.Analysis.DataFlowSpec
Language.Fortran.Analysis.ModFileSpec
Language.Fortran.Analysis.ModGraphSpec
Language.Fortran.Analysis.RenamingSpec
Language.Fortran.Analysis.SemanticTypesSpec
Expand Down
2 changes: 1 addition & 1 deletion package.yaml
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
name: fortran-src
version: '0.15.1'
version: '0.16.0'
synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial).
description: >-
Provides lexing, parsing, and basic analyses of Fortran code covering
Expand Down
26 changes: 24 additions & 2 deletions src/Language/Fortran/Analysis.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,8 @@ module Language.Fortran.Analysis
( initAnalysis, stripAnalysis, Analysis(..)
, varName, srcName, lvVarName, lvSrcName, isNamedExpression
, genVar, puName, puSrcName, blockRhsExprs, rhsExprs
, ModEnv, NameType(..), IDType(..), ConstructType(..)
, ModEnv, NameType(..), Locality(..), markAsImported, isImported
, IDType(..), ConstructType(..)
, lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars
, blockVarUses, blockVarDefs
, BB, BBNode, BBGr(..), bbgrMap, bbgrMapM, bbgrEmpty
Expand Down Expand Up @@ -77,10 +78,31 @@ type TransFunc f g a = (f (Analysis a) -> f (Analysis a)) -> g (Analysis a) -> g
type TransFuncM m f g a = (f (Analysis a) -> m (f (Analysis a))) -> g (Analysis a) -> m (g (Analysis a))

-- Describe a Fortran name as either a program unit or a variable.
data NameType = NTSubprogram | NTVariable | NTIntrinsic deriving (Show, Eq, Ord, Data, Typeable, Generic)
data Locality =
Local -- locally declared
| Imported -- declared in an imported module
deriving (Show, Eq, Ord, Data, Typeable, Generic)

data NameType = NTSubprogram Locality | NTVariable Locality | NTIntrinsic
deriving (Show, Eq, Ord, Data, Typeable, Generic)

instance Binary NameType
instance Out NameType

instance Binary Locality
instance Out Locality

-- Mark any variables as being imported
markAsImported :: NameType -> NameType
markAsImported (NTVariable _) = NTVariable Imported
markAsImported (NTSubprogram _) = NTSubprogram Imported
markAsImported x = x

isImported :: NameType -> Bool
isImported (NTVariable Imported) = True
isImported (NTSubprogram Imported) = True
isImported _ = False

-- Module environments are associations between source name and
-- (unique name, name type) in a specific module.
type ModEnv = M.Map String (String, NameType)
Expand Down
1 change: 0 additions & 1 deletion src/Language/Fortran/Analysis/ModGraph.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,7 +16,6 @@ import Data.Data
import Data.Generics.Uniplate.Data
import Data.Graph.Inductive hiding (version)
import Data.Maybe
import Data.Either.Combinators ( fromRight' )
import qualified Data.Map as M

--------------------------------------------------
Expand Down
33 changes: 20 additions & 13 deletions src/Language/Fortran/Analysis/Renaming.hs
Original file line number Diff line number Diff line change
Expand Up @@ -120,7 +120,7 @@ programUnit (PUFunction a s ty rec name args res blocks m_contains) = do
blocks3 <- mapM renameDeclDecls blocks2 -- handle declarations
m_contains' <- renameSubPUs m_contains -- handle contained program units
blocks4 <- mapM renameBlock blocks3 -- process all uses of variables
let env = M.singleton name (name', NTSubprogram)
let env = M.singleton name (name', NTSubprogram Local)
let a' = a { moduleEnv = Just env } -- also annotate it on the program unit
popScope
let pu' = PUFunction a' s ty rec name args' res' blocks4 m_contains'
Expand All @@ -133,7 +133,7 @@ programUnit (PUSubroutine a s rec name args blocks m_contains) = do
blocks2 <- mapM renameDeclDecls blocks1 -- handle declarations
m_contains' <- renameSubPUs m_contains -- handle contained program units
blocks3 <- mapM renameBlock blocks2 -- process all uses of variables
let env = M.singleton name (name', NTSubprogram)
let env = M.singleton name (name', NTSubprogram Local)
let a' = a { moduleEnv = Just env } -- also annotate it on the program unit
popScope
let pu' = PUSubroutine a' s rec name args' blocks3 m_contains'
Expand Down Expand Up @@ -230,10 +230,16 @@ initialEnv blocks = do
mMap <- gets moduleMap
modEnv <- fmap M.unions . forM uses $ \ use -> case use of
(BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ Nothing)) ->
return $ fromMaybe empty (Named m `lookup` mMap)
let
env = fromMaybe empty (Named m `lookup` mMap)
-- mark as imported all the local things from this module
in return $ M.map (\ (v, info) -> (v, markAsImported info)) env

(BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ (Just onlyAList)))
| only <- aStrip onlyAList -> do
let env = fromMaybe empty (Named m `lookup` mMap)
-- mark as imported all the local things from this module
env <- return $ M.map (\ (v, info) -> (v, markAsImported info)) env
-- list of (local name, original name) from USE declaration:
let localNamePairs = flip mapMaybe only $ \ r -> case r of
UseID _ _ v@(ExpValue _ _ ValVariable{}) -> Just (varName v, varName v)
Expand All @@ -253,7 +259,7 @@ initialEnv blocks = do

-- Include any mappings defined by COMMON blocks: use variable
-- source name prefixed by name of COMMON block.
let common = M.fromList [ (v, (v', NTVariable))
let common = M.fromList [ (v, (v', NTVariable Local))
| CommonGroup _ _ me1 alist <- universeBi blocks :: [CommonGroup (Analysis a)]
, let prefix = case me1 of Just e1 -> srcName e1; _ -> ""
, e@(ExpValue _ _ ValVariable{}) <- universeBi (aStrip alist) :: [Expression (Analysis a)]
Expand Down Expand Up @@ -325,9 +331,9 @@ getFromEnvsIfSubprogram :: String -> Renamer (Maybe String)
getFromEnvsIfSubprogram v = do
mEntry <- getFromEnvsWithType v
case mEntry of
Just (v', NTSubprogram) -> return $ Just v'
Just (_, NTVariable) -> getFromEnv v
_ -> return Nothing
Just (v', NTSubprogram _) -> return $ Just v'
Just (_, NTVariable _) -> getFromEnv v
_ -> return Nothing

-- Add a renaming mapping to the environment.
addToEnv :: String -> String -> NameType -> Renamer ()
Expand Down Expand Up @@ -372,10 +378,10 @@ renameSubPUs (Just pus) = skimProgramUnits pus >> Just <$> mapM programUnit pus
-- to the environment.
skimProgramUnits :: Data a => [ProgramUnit (Analysis a)] -> Renamer ()
skimProgramUnits pus = forM_ pus $ \ pu -> case pu of
PUModule _ _ name _ _ -> addToEnv name name NTSubprogram
PUFunction _ _ _ _ name _ _ _ _ -> addUnique_ name NTSubprogram
PUSubroutine _ _ _ name _ _ _ -> addUnique_ name NTSubprogram
PUMain _ _ (Just name) _ _ -> addToEnv name name NTSubprogram
PUModule _ _ name _ _ -> addToEnv name name (NTSubprogram Local)
PUFunction _ _ _ _ name _ _ _ _ -> addUnique_ name (NTSubprogram Local)
PUSubroutine _ _ _ name _ _ _ -> addUnique_ name (NTSubprogram Local)
PUMain _ _ (Just name) _ _ -> addToEnv name name (NTSubprogram Local)
_ -> return ()

----------
Expand All @@ -394,7 +400,8 @@ renameGenericDecls = trans renameExpDecl
-- declaration that possibly requires the creation of a new unique
-- mapping.
renameExpDecl :: Data a => RenamerFunc (Expression (Analysis a))
renameExpDecl e@(ExpValue _ _ (ValVariable v)) = flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v NTVariable
renameExpDecl e@(ExpValue _ _ (ValVariable v)) =
flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v (NTVariable Local)
-- Intrinsics get unique names for each use.
renameExpDecl e@(ExpValue _ _ (ValIntrinsic v)) = flip setUniqueName (setSourceName v e) `fmap` addUnique v NTIntrinsic
renameExpDecl e = return e
Expand All @@ -407,7 +414,7 @@ renameInterfaces = trans interface

interface :: Data a => RenamerFunc (Block (Analysis a))
interface (BlInterface a s (Just e@(ExpValue _ _ (ValVariable v))) abst pus bs) = do
e' <- flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v NTSubprogram
e' <- flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v (NTSubprogram Local)
pure $ BlInterface a s (Just e') abst pus bs
interface b = pure b

Expand Down
14 changes: 14 additions & 0 deletions src/Language/Fortran/Repr/Value/Machine.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@

module Language.Fortran.Repr.Value.Machine where

import Language.Fortran.Repr.Value.Scalar.Real
import Language.Fortran.Repr.Value.Scalar.Int.Machine
import Language.Fortran.Repr.Value.Scalar.Machine
import Language.Fortran.Repr.Type

Expand All @@ -18,3 +20,15 @@ data FValue = MkFScalarValue FScalarValue
fValueType :: FValue -> FType
fValueType = \case
MkFScalarValue a -> MkFScalarType $ fScalarValueType a

fromConstInt :: FValue -> Maybe Integer
fromConstInt (MkFScalarValue (FSVInt a)) = Just $ withFInt a
fromConstInt _ = Nothing

fromConstReal :: FValue -> Maybe Double
fromConstReal (MkFScalarValue (FSVReal (FReal4 a))) = Just $ floatToDouble a
where
floatToDouble :: Float -> Double
floatToDouble = realToFrac
fromConstReal (MkFScalarValue (FSVReal (FReal8 a))) = Just $ a
fromConstReal _ = Nothing
2 changes: 1 addition & 1 deletion src/Language/Fortran/Repr/Value/Scalar/Machine.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,4 +55,4 @@ fScalarValueType = \case
FSVReal a -> FSTReal $ fKind a
FSVComplex a -> FSTComplex $ fKind a
FSVLogical a -> FSTLogical $ fKind a
FSVString a -> FSTString $ fromIntegral $ Text.length a
FSVString a -> FSTString $ fromIntegral $ Text.length a
14 changes: 11 additions & 3 deletions src/Language/Fortran/Util/ModFile.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ module Language.Fortran.Util.ModFile
, moduleFilename
, StringMap, extractStringMap, combinedStringMap
, DeclContext(..), DeclMap, extractDeclMap, combinedDeclMap
, extractModuleMap, combinedModuleMap, combinedTypeEnv
, extractModuleMap, combinedModuleMap, localisedModuleMap, combinedTypeEnv
, ParamVarMap, extractParamVarMap, combinedParamVarMap
, genUniqNameToFilenameMap
, TimestampStatus(..), checkTimestamps
Expand Down Expand Up @@ -217,6 +217,11 @@ decodeModFiles' = fmap (map snd) . decodeModFiles
combinedModuleMap :: ModFiles -> FAR.ModuleMap
combinedModuleMap = M.unions . map mfModuleMap

-- | Inside the module map, remove all imported declarations so that
-- we can properly localise declarations to the originator file.
localisedModuleMap :: FAR.ModuleMap -> FAR.ModuleMap
localisedModuleMap = M.map (M.filter (not . FA.isImported . snd))
dorchard marked this conversation as resolved.
Show resolved Hide resolved

-- | Extract the combined module map from a set of ModFiles. Useful
-- for parsing a Fortran file in a large context of other modules.
combinedTypeEnv :: ModFiles -> FAT.TypeEnv
Expand Down Expand Up @@ -244,13 +249,16 @@ moduleFilename = mfFilename
--------------------------------------------------

-- | Create a map that links all unique variable/function names in the
-- ModFiles to their corresponding filename.
-- ModFiles to their corresponding *originating* filename (i.e., where they are declared)
genUniqNameToFilenameMap :: ModFiles -> M.Map F.Name String
genUniqNameToFilenameMap = M.unions . map perMF
where
perMF mf = M.fromList [ (n, fname) | modEnv <- M.elems (mfModuleMap mf)
perMF mf = M.fromList [ (n, fname) | modEnv <- M.elems localModuleMap
, (n, _) <- M.elems modEnv ]
where
-- Make sure that we remove imported declarations so we can
-- properly localise declarations to the originator file.
localModuleMap = localisedModuleMap $ mfModuleMap mf
fname = mfFilename mf

--------------------------------------------------
Expand Down
46 changes: 46 additions & 0 deletions test/Language/Fortran/Analysis/ModFileSpec.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,46 @@
module Language.Fortran.Analysis.ModFileSpec (spec) where

import Test.Hspec
import TestUtil

import Language.Fortran.Util.ModFile
import Language.Fortran.Util.Files (expandDirs, flexReadFile)
import Language.Fortran.Version
import System.FilePath ((</>))
import qualified Data.Map as M
import qualified Language.Fortran.Parser as Parser
import qualified Data.ByteString.Char8 as B
import Language.Fortran.AST
import Language.Fortran.Analysis
import Language.Fortran.Analysis.Renaming
import Language.Fortran.Analysis.BBlocks
import Language.Fortran.Analysis.DataFlow

spec :: Spec
spec =
describe "Modfiles" $
it "Test module maps for a small package" $
testModuleMaps

pParser :: String -> IO (ProgramFile (Analysis A0))
pParser name = do
contents <- flexReadFile name
let pf = Parser.byVerWithMods [] Fortran90 name contents
case pf of
Right pf -> return $ rename . analyseBBlocks . analyseRenames . initAnalysis $ pf
Left err -> error $ "Error parsing " ++ name ++ ": " ++ show err

-- A simple test that checks that we correctly localise the declaration
-- of the variable `constant` to the leaf module, whilst understanding
-- in the `mid1` and `mid2` modules that it is an imported declaration.
testModuleMaps = do
paths <- expandDirs ["test-data" </> "module"]
-- parse all files into mod files
pfs <- mapM (\p -> pParser p) paths
let modFiles = map genModFile pfs
-- get unique name to filemap
let mmap = genUniqNameToFilenameMap modFiles
-- check that `constant` is declared in leaf.f90
let Just leaf = M.lookup "leaf_constant_1" mmap
leaf `shouldBe` ("test-data" </> "module" </> "leaf.f90")

10 changes: 7 additions & 3 deletions test/Language/Fortran/Analysis/ModGraphSpec.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
module Language.Fortran.Analysis.ModGraphSpec (spec) where

import Test.Hspec
import TestUtil

Check warning on line 4 in test/Language/Fortran/Analysis/ModGraphSpec.hs

View workflow job for this annotation

GitHub Actions / Ubuntu / GHC 9.0, Cabal / test

The import of ‘TestUtil’ is redundant

Check warning on line 4 in test/Language/Fortran/Analysis/ModGraphSpec.hs

View workflow job for this annotation

GitHub Actions / Ubuntu / GHC 9.2, Cabal / test

The import of ‘TestUtil’ is redundant

import Language.Fortran.Analysis.ModGraph
import Language.Fortran.Util.Files (expandDirs)
Expand All @@ -17,10 +17,14 @@
-- A simple test on a simple module structure to check that
-- we are understanding this correctly (via the dependency graph
-- and then its topological sort).
testDependencyList = do

Check warning on line 20 in test/Language/Fortran/Analysis/ModGraphSpec.hs

View workflow job for this annotation

GitHub Actions / Ubuntu / GHC 9.0, Cabal / test

Top-level binding with no type signature:

Check warning on line 20 in test/Language/Fortran/Analysis/ModGraphSpec.hs

View workflow job for this annotation

GitHub Actions / Ubuntu / GHC 9.2, Cabal / test

Top-level binding with no type signature:
paths' <- expandDirs ["test-data" </> "module"]
mg <- genModGraph (Just Fortran90) ["."] Nothing paths'
let list = modGraphToList mg
let files = ["leaf.f90", "mid1.f90", "mid2.f90", "top.f90"]
let filesWithPaths = map (("test-data" </> "module") </>) files
list `shouldBe` filesWithPaths
-- we should have two possible orderings
let files1 = ["leaf.f90", "mid1.f90", "mid2.f90", "top.f90"]
let filesWithPaths1 = map (("test-data" </> "module") </>) files1
-- or in a different order
let files2 = ["leaf.f90", "mid2.f90", "mid1.f90", "top.f90"]
let filesWithPaths2 = map (("test-data" </> "module") </>) files2
shouldSatisfy list (\x -> x == filesWithPaths1 || x == filesWithPaths2)
Loading