-
Notifications
You must be signed in to change notification settings - Fork 140
/
Depend.hs
424 lines (391 loc) · 17.4 KB
/
Depend.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
{-# LANGUAGE CPP #-}
module Depend(chkDeps, parseSrc, chkParse, doCPP, genDepend, genFileDepend) where
import Data.Maybe(isJust)
import Data.List(nub)
import Control.Monad(when)
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 703)
import System.Process(system)
#else
import System.Cmd(system)
#endif
import System.Exit(ExitCode(..))
import System.Directory(getModificationTime)
import System.Time -- XXX: in old-time package
#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__>=705)
import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds)
#endif
import qualified Control.Exception as CE
import qualified Data.Map as DM
import TmpNam(tmpNam)
import SCC(tsort)
import Flags
import Backend
import Pragma(Pragma(..),PProp(..))
import Position(noPosition)
import Error(internalError, EMsg, ErrMsg(..), ErrorHandle, bsError,
exitFailWith, bsWarning)
import PFPrint
import FStringCompat
import Lex
import Parse
import FileNameUtil(hasDotSuf, dropSuf, baseName, dirName,
bscSrcSuffix, bsvSrcSuffix, binSuffix,
mkAName, mkVName, mkVPIHName, mkVPICName)
import FileIOUtil(readFilesPath, readBinFilePath, readFileCatch, writeFileCatch,
removeFileCatch)
import Id
import PreIds(idPrelude, idPreludeBSV)
import Parser.Classic(pPackage, errSyntax, classicWarnings)
import Parser.BSV(bsvParseString)
import CSyntax
import GenFuncWrap(makeGenFuncId)
import IOUtil(getEnvDef, progArgs)
import TopUtils
--import Trace
--import Util(traceM)
outlaw_sv_kws_as_classic_ids = "-outlaw-sv-kws-as-classic-ids" `elem` progArgs
type FileName = String
type PkgName = Id
type ModName = Id
type ForeignName = Id
type MClockTime = Maybe ClockTime
data PkgInfo = PkgInfo {
pkgName :: PkgName,
fileName :: FileName,
srcMod :: MClockTime,
lastMod :: MClockTime,
imports :: [PkgName],
includes :: [FileName],
gens :: [ModName],
foreigns :: [ForeignName],
recompile :: Bool,
isbin :: Bool
}
deriving (Show)
-- In GHC 7.6, the return type of getModificationTime changed
getModificationTime' :: FilePath -> IO ClockTime
getModificationTime' file =
#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__>=705)
do utcTime <- getModificationTime file
let s = (floor . utcTimeToPOSIXSeconds) utcTime
return (TOD s 0)
#else
getModificationTime file
#endif
-- returns a list of Bluespec source files which need recompiling.
-- (This used to also return a list of all generated files which would
-- result from codegen, so that a later stage could link them. But this
-- feature is no longer supported.)
chkDeps :: ErrorHandle -> Flags -> String -> IO [FileName]
chkDeps errh flags name = do
let gflags = [ mkId noPosition (mkFString s) | s <- genName flags ]
pi <- getInfo errh flags gflags name
(errs,pis) <- transClose errh flags ([],[pi]) (imports pi)
when (not $ null errs) $ bsError errh errs
case tsort [ (n, is) | PkgInfo { pkgName = n, imports = is } <- pis ] of
Left cycle@(firstImport:_) ->
bsError errh [(getPosition firstImport,
ECircularImports (map ppReadable cycle))]
Right ns -> do
let -- the pkginfo of all depended modules
pis' = [ pi | n <- ns, let Just pi = findInfo n pis ]
-- names of files resulting from codegen, if we want
-- to return them, for a linking stage to use
--genfs = concatMap (getGenFs flags) pis'
-- the pkginfos with "recompile" marked for any files whose
-- source is newer than any of its related files
pis'' <- chkUpd flags [] pis'
-- just the names of the pkgs to be recompiled,
-- in dependency order
let fs = reverse [ f | PkgInfo { fileName = f, recompile = True } <- pis'' ]
return fs
Left [] -> internalError "Depend.chkDeps: tsort empty cycle"
-- Get PkgInfo for a package name. Try to open the corresponding file.
-- Also try the .bo file (for installed libraries).
getPkgInfo :: ErrorHandle -> Flags -> PkgName -> IO (Either EMsg PkgInfo)
getPkgInfo errh flags pname =
let name = getIdString pname ++ "." ++ bscSrcSuffix
bsvname = getIdString pname ++ "." ++ bsvSrcSuffix
bname = getIdString pname ++ "." ++ binSuffix
path = ifcPath flags
errPackageMissing = (getIdPosition pname,
EMissingPackage (pfpString pname))
die_nameMismatch fname pname =
bsError errh [(getIdPosition pname,
WFilePackageNameMismatch
(pfpString fname) (pfpString pname))]
trybsv :: IO (Maybe PkgInfo)
trybsv = do
mfile <- readFilesPath errh noPosition False [bsvname, name] path
case mfile of
Nothing -> return Nothing
Just (_, fname) -> do
pi <- getInfo errh flags [] fname
-- XXX return the EMsg instead of dying?
when (pkgName pi /= pname)
(die_nameMismatch pname (pkgName pi))
return (Just pi)
trybo :: IO (Maybe PkgInfo)
trybo = do
mfile <- readBinFilePath errh noPosition False bname path
case mfile of
Nothing -> return Nothing
Just (file, fname) ->
-- this comparison forces evaluation to force close on the file
if file /= file then internalError "getPkgInfo" else do
t <- getModTime fname
return $ Just $
PkgInfo { pkgName = pname, fileName = fname,
srcMod = Nothing, lastMod = t, imports = [], includes = [],
gens = [], foreigns = [], recompile = False,
isbin = True }
-- if a stage returns Nothing, then try the next stage;
-- once a stage returns something, return it
contIfNothing :: IO (Maybe a) -> Maybe a -> IO (Maybe a)
contIfNothing fn Nothing = fn
contIfNothing fn res = return res
in
-- any IO failure along the way aborts the process
trybsv >>=
contIfNothing trybo >>=
\res -> case res of
Nothing -> return (Left errPackageMissing)
Just pi -> return (Right pi)
-- Get PkgInfo for a string (from a given file name), fail if not parsable.
getInfo :: ErrorHandle -> Flags -> [ModName] -> FileName -> IO PkgInfo
getInfo errh flags gflags fname = do
file' <- doCPP errh flags fname
let isClassic = not $ hasDotSuf bsvSrcSuffix fname
-- setClassic isClassic
(CPackage i _ imps _ defs incs, _)
<- parseSrc isClassic errh flags False fname file'
-- the mod time of the source file
tbs <- getModTime fname
-- function to change fname's path to a new directory
-- (like TopUtils::putInDir)
let mkdname dir suf = dir ++ "/" ++ baseName (dropSuf fname) ++ "." ++ suf
-- find the mod time of the bo file (either in same dir or in the bdir)
tbo_samedir <- getModTime (dropSuf fname ++ "." ++ binSuffix)
tbo_bdir <- case (bdir flags) of
Nothing -> return Nothing
Just dir -> getModTime (mkdname dir binSuffix)
let tbo = if (isJust tbo_bdir) then tbo_bdir else tbo_samedir
-- include the prelude to avoid failures when predule was updated.
let prelude = if (not $ usePrelude flags) || (i == idPrelude)
then []
else if (i == idPreludeBSV)
then [idPrelude]
else [idPrelude, idPreludeBSV]
return $ PkgInfo {
pkgName = i,
fileName = fname,
srcMod = tbs,
lastMod = tbs `max` tbo,
imports = [ i | CImpId _ i <- imps] ++ prelude,
includes = [i | CInclude i <- incs],
recompile = tbo < tbs,
gens = [ i | CPragma (Pproperties i pps) <- defs,
PPverilog `elem` pps ] ++
[ i | CValueSign (CDef i _ _) <- defs,
i `elem` gflags ] ++
[ makeGenFuncId i
| CPragma (Pnoinline is) <- defs,
i <- is ],
foreigns = [ i | CPragma (Pproperties _ pps) <- defs,
(PPforeignImport i) <- pps ],
isbin = False }
-- Compute the transitive closure of all imports.
-- The `done' arg are the already visited packages,
-- and the `ns' arg are the names of the remaining ones.
transClose :: ErrorHandle -> Flags -> ([EMsg],[PkgInfo]) -> [PkgName] ->
IO ([EMsg],[PkgInfo])
transClose errh flags done [] = return done
transClose errh flags (errs,done) (n:ns) = do
--putStr (ppReadable n)
case findInfo n done of
Just _ -> transClose errh flags (errs,done) ns
Nothing -> do
epi <- getPkgInfo errh flags n
case epi of
Left em -> transClose errh flags (em:errs,done) (ns)
Right pi -> transClose errh flags (errs,pi:done) (ns ++ imports pi)
findInfo :: PkgName -> [PkgInfo] -> Maybe PkgInfo
findInfo _ [] = Nothing
findInfo n (pi@(PkgInfo { pkgName = n' }):_) | n == n' = Just pi
findInfo n (_:pis) = findInfo n pis
-- This tries to return a list of all files that will be generated from
-- this file after codegen.
-- XXX This needs to be kept in sync with what the backend actually does!
getGenFs flags pi =
let prefix = dirName (fileName pi) ++ "/"
getName = getIdString . unQualId
mkABinFileName i = mkAName (bdir flags) prefix (getName i)
mkVerFileName i = mkVName (vdir flags) prefix (getName i)
mkVPIFileNames i = [ mkVPIHName (vdir flags) prefix (getName i),
mkVPICName (vdir flags) prefix (getName i) ]
-- files common to all backends
foreign_abin_files = map mkABinFileName (foreigns pi)
in case backend flags of
Just Bluesim ->
let mod_abin_files = map mkABinFileName (gens pi)
in foreign_abin_files ++ mod_abin_files
Just Verilog ->
let mod_ver_files = map mkVerFileName (gens pi)
foreign_vpi_files = concatMap mkVPIFileNames (foreigns pi)
mod_abin_files =
if (genABin flags)
then map mkABinFileName (gens pi)
else []
in foreign_abin_files ++ foreign_vpi_files ++
mod_ver_files ++ mod_abin_files
Nothing ->
foreign_abin_files
-- Update the `recompile' flag in all the PkgInfo.
chkUpd :: Flags -> [PkgInfo] -> [PkgInfo] -> IO [PkgInfo]
chkUpd flags done [] = return done
chkUpd flags done (pi:pis) = do
--putStrLn ("chkUpd " ++ show pi)
let genfs = getGenFs flags pi
let incfs = includes pi
--putStrLn (show genfs)
genfsClks <- mapM getModTime genfs
incfsClks <- mapM getModTime incfs
let needGenUpd = any (srcMod pi >) genfsClks
let needIncUpd = any (lastMod pi <) incfsClks
--putStrLn (show (fileName pi, genfs, map (srcMod pi >) genfsClks))
--putStr (ppReadable (pkgName pi, imports pi, map pkgName done))
let pi' = pi { recompile = True }
if isPreludePkg flags (fileName pi) || isbin pi then
-- Never update Prelude files
chkUpd flags (pi : done) pis
else do
-- Update if the package (i.e. .bo) or any generated files (i.e. .ba/.v)
-- are out-of-date with respect to any import
-- or the generated files are out-of-date with respect to the source.
let lastCompTime = minimum ((lastMod pi) : genfsClks)
if any (needsUpd lastCompTime done) (imports pi) || needGenUpd || needIncUpd then
chkUpd flags (pi' : done) pis
else
chkUpd flags (pi : done) pis
-- Is this an installed library?
isPreludePkg :: Flags -> FileName -> Bool
isPreludePkg flags n =
let sl = bluespecDir flags ++ "/Libraries/"
in take (length sl) n == sl
-- Check if out-of-date with respect to an imported module.
-- Recompilation is needed if the imported file will be
-- recompiled or if it has a later date stamp.
needsUpd :: MClockTime -> [PkgInfo] -> PkgName -> Bool
needsUpd myMod pis n =
case findInfo n pis of
Nothing -> internalError ("needsUpd " ++ pfpString n)
Just pi -> recompile pi || lastMod pi > myMod
getModTime :: String -> IO MClockTime
getModTime f = CE.catch (getModificationTime' f >>= return . Just) handler
where handler :: ExceptionType -> IO MClockTime
handler _ = return Nothing
-----
doCPP :: ErrorHandle -> Flags -> String -> IO String
doCPP errh flags name =
if cpp flags
then do
tempName <- tmpNam
let topName = "_t_o_p.c"
tmpNameOut = tempName ++ ".out"
writeFileCatch errh topName ("#include \""++name++"\"\n")
comp <- getEnvDef "CC" dfltCCompile
{- If the compiler specified in the CC environment variable has a
spaces in its name, for example CC="/usr/local/my c compiler/bin/cc",
then this will fail. You need to properly quote the spaces. As a
side effect, (and in fact, this was the reason why), if you include
flags in the CC variable, for example CC="cc -g", then it will work.
-}
let backend_def = case backend flags of
Just Bluesim -> ["-D__GENC__"]
Just Verilog -> ["-D__GENVERILOG__"]
Nothing -> []
cmd = unwords ([comp] ++ backend_def ++
["-D__BSC__", "-E", "-nostdinc", "-traditional"] ++
-- the show function quotes things
(map show (cppFlags flags))
++ [ topName, ">", tmpNameOut])
when (verbose flags) $ putStrLn ("exec: " ++ cmd)
rc <- system cmd
case rc of
ExitSuccess -> do
file <- readFileCatch errh noPosition tmpNameOut
removeFileCatch errh topName
removeFileCatch errh tmpNameOut
return file
ExitFailure n -> do
removeFileCatch errh topName
removeFileCatch errh tmpNameOut
exitFailWith errh n
else readFileCatch errh noPosition name
parseSrc :: Bool -> ErrorHandle -> Flags -> Bool -> String -> String ->
IO (CPackage, TimeInfo)
parseSrc True errh flags show_warns filename inp = do
-- Classic parser
t <- getNow
let dumpnames = (baseName (dropSuf filename), "", "")
start flags DFparsed
let lflags = LFlags { lf_is_stdlib = stdlibNames flags,
lf_allow_sv_kws = not outlaw_sv_kws_as_classic_ids }
case chkParse pPackage (lexStart lflags (mkFString filename) inp) of
Right pkg -> do t <- dump errh flags t DFparsed dumpnames pkg
let ws = classicWarnings pkg
when (show_warns && (not $ null ws)) $ bsWarning errh ws
return (pkg, t)
Left errs -> bsError errh errs
parseSrc False errh flags show_warns filename inp =
-- BSV parser
bsvParseString errh flags show_warns filename (baseName $ dropSuf filename) inp
chkParse :: Parser [Token] a -> [Token] -> Either [EMsg] a
chkParse p ts =
case parse p ts of
Right ((m,_):_) -> Right m
Left (ss,ts) -> Left [errSyntax (filter (not . null ) ss) ts]
Right [] -> internalError "Depend.chkParse: Right []"
----
findPackages :: ErrorHandle -> Flags -> FileName -> IO ([EMsg],[PkgInfo])
findPackages errh flags name = do
let gflags = [ mkId noPosition (mkFString s) | s <- genName flags ]
pi <- getInfo errh flags gflags name
transClose errh flags ([],[pi]) (imports pi)
-- generate the file name dependancies for filename
-- A package depends on its own source file name
-- plus the imported packages (.bo)
-- plus the included files
genDepend :: ErrorHandle -> Flags -> FileName ->
IO ([EMsg],[(FileName, [FileName])])
genDepend errh flags name = do
(errs,pis) <- findPackages errh flags name
let pmap :: DM.Map PkgName PkgInfo
pmap = DM.fromList [(pkgName pki, pki) | pki <- pis]
lookupP p =
case (DM.lookup p pmap) of
Just pinfo -> [pinfo]
Nothing -> [] -- internalError $ "Depend:genDepend " ++ show p
--
-- bo name and location
boName p = putInDir (bdir flags) (fileName p) binSuffix
-- bsv source file (if it exists)
getSelf p | isbin p = []
| otherwise = [fileName p]
--
getImports p = -- package name .bo
let fnp p | isbin p = fileName p
| otherwise = boName p
in map fnp (concatMap lookupP (imports p))
--
extr :: PkgInfo -> [(FileName, [FileName])]
extr pki | isbin pki = []
extr pki = [(boName pki, getSelf pki ++ getImports pki ++ includes pki)]
return (errs,concatMap extr pis)
genFileDepend :: ErrorHandle -> Flags -> FileName -> IO ([EMsg],[FileName])
genFileDepend errh flags name = do
(errs,pis) <- findPackages errh flags name
let extrFiles :: PkgInfo -> [FileName]
extrFiles p | isbin p = []
| otherwise = fileName p : includes p
return (errs, nub $ concatMap extrFiles pis)