-
Notifications
You must be signed in to change notification settings - Fork 147
/
Driver.hs
586 lines (534 loc) · 23.5 KB
/
Driver.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
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
{-|
Copyright : (C) 2012-2016, University of Twente,
2016-2017, Myrtle Software Ltd,
2017 , QBayLogic, Google Inc.
License : BSD2 (see the file LICENSE)
Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>
Module that connects all the parts of the Clash compiler library
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Clash.Driver where
import qualified Control.Concurrent.Supply as Supply
import Control.DeepSeq
import Control.Exception (tryJust, bracket)
import Control.Lens (use, view, (^.), _3, _4)
import Control.Monad (guard, when, unless, join, foldM)
import Control.Monad.State (evalState, get)
import Data.Hashable (hash)
import qualified Data.HashSet as HashSet
import Data.IntMap (IntMap)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Semigroup.Monad
import qualified Data.Text
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.IO as Text
import Data.Text.Prettyprint.Doc (pretty)
import Data.Text.Prettyprint.Doc.Extra
(Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy,
renderOneLine)
import qualified Data.Time.Clock as Clock
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.Interpreter.Unsafe as Hint
import qualified System.Directory as Directory
import System.Environment (getExecutablePath)
import System.FilePath ((</>), (<.>))
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import System.IO.Error (isDoesNotExistError)
import System.IO.Temp
(getCanonicalTemporaryDirectory, withTempDirectory)
import qualified Text.PrettyPrint.ANSI.Leijen as ANSI
import Text.Trifecta.Result
(Result(Success, Failure), _errDoc)
import Text.Read (readMaybe)
import SrcLoc (SrcSpan)
import GHC.BasicTypes.Extra ()
import Clash.Annotations.Primitive (HDL (..))
import Clash.Annotations.BitRepresentation.Internal
(CustomReprs)
import Clash.Annotations.TopEntity (TopEntity (..))
import Clash.Annotations.TopEntity.Extra ()
import Clash.Backend
import Clash.Core.Evaluator (PrimEvaluator)
import Clash.Core.Name (Name (..))
import Clash.Core.Term (Term)
import Clash.Core.Type (Type)
import Clash.Core.TyCon (TyConMap, TyConName)
import Clash.Core.Var (Id, varName)
import Clash.Core.VarEnv (InScopeSet, emptyVarEnv)
import Clash.Driver.Types
import Clash.Netlist (genNetlist)
import Clash.Netlist.Util (genComponentName, genTopComponentName)
import Clash.Netlist.BlackBox.Parser (runParse)
import Clash.Netlist.BlackBox.Types (BlackBoxTemplate, BlackBoxFunction)
import Clash.Netlist.Types
(BlackBox (..), Component (..), HWType, Identifier)
import Clash.Normalize (checkNonRecursive, cleanupGraph,
normalize, runNormalization)
import Clash.Normalize.Util (callGraph)
import Clash.Rewrite.Types (globalInScope)
import Clash.Primitives.Types
import Clash.Primitives.Util (hashCompiledPrimMap)
import Clash.Unique (keysUniqMap, lookupUniqMap')
import Clash.Util (first)
-- | Get modification data of current clash binary.
getClashModificationDate :: IO Clock.UTCTime
getClashModificationDate = Directory.getModificationTime =<< getExecutablePath
-- | Create a set of target HDL files for a set of functions
generateHDL
:: forall backend . Backend backend
=> CustomReprs
-> BindingMap
-- ^ Set of functions
-> Maybe backend
-> CompiledPrimMap
-- ^ Primitive / BlackBox Definitions
-> TyConMap
-- ^ TyCon cache
-> IntMap TyConName
-- ^ Tuple TyCon cache
-> (CustomReprs -> TyConMap -> Bool -> Type -> Maybe (Either String HWType))
-- ^ Hardcoded 'Type' -> 'HWType' translator
-> PrimEvaluator
-- ^ Hardcoded evaluator (delta-reduction)
-> [( Id
, Maybe TopEntity
, Maybe Id
)]
-- ^ topEntity bndr
-- + (maybe) TopEntity annotation
-- + (maybe) testBench bndr
-> ClashOpts
-- ^ Debug information level for the normalization process
-> (Clock.UTCTime,Clock.UTCTime)
-> IO ()
generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval
topEntities opts (startTime,prepTime) = go prepTime [] topEntities where
go prevTime _ [] = putStrLn $ "Total compilation took " ++
show (Clock.diffUTCTime prevTime startTime)
-- Process the next TopEntity
go prevTime seen ((topEntity,annM,benchM):topEntities') = do
let topEntityS = Data.Text.unpack (nameOcc (varName topEntity))
putStrLn $ "Compiling: " ++ topEntityS
-- Some initial setup
let modName1 = takeWhile (/= '.') topEntityS
(modName,prefixM) = case opt_componentPrefix opts of
Just p
| not (null p) -> case annM of
-- Prefix top names with 'p', prefix other with 'p_tname'
Just ann ->
let nm = p ++ ('_':t_name ann)
in (nm,(Just (Data.Text.pack p),Just (Data.Text.pack nm)))
-- Prefix top names with 'p', prefix other with 'p'
_ -> (p ++ '_':modName1,(Just (Data.Text.pack p),Just (Data.Text.pack p)))
| Just ann <- annM -> case hdlKind (undefined :: backend) of
-- Prefix other with 't_name'
VHDL -> (t_name ann,(Nothing,Just (Data.Text.pack (t_name ann))))
_ -> (t_name ann,(Nothing,Nothing))
_ -> case annM of
Just ann -> case hdlKind (undefined :: backend) of
VHDL -> (t_name ann, (Nothing,Nothing))
-- Prefix other with 't_name'
_ -> (t_name ann, (Nothing,Just (Data.Text.pack (t_name ann))))
_ -> (modName1, (Nothing,Nothing))
iw = opt_intWidth opts
hdlsyn = opt_hdlSyn opts
hdlState' = setModName (Data.Text.pack modName)
$ fromMaybe (initBackend iw hdlsyn :: backend) hdlState
hdlDir = fromMaybe "." (opt_hdlDir opts) </>
Clash.Backend.name hdlState' </>
takeWhile (/= '.') topEntityS
mkId = evalState mkIdentifier hdlState'
extId = evalState extendIdentifier hdlState'
topNm = genTopComponentName mkId prefixM annM topEntity
topNmU = Data.Text.unpack topNm
unless (opt_cachehdl opts) $ putStrLn "Ignoring .manifest files"
-- Calculate the hash over the callgraph and the topEntity annotation
(sameTopHash,sameBenchHash,manifest) <- do
clashModDate <- getClashModificationDate
let primMapHash = hashCompiledPrimMap primMap
let
topHash =
hash ( annM
, primMapHash
, show clashModDate
, callGraphBindings bindingsMap topEntity
)
let
benchHashM =
case benchM of
Nothing -> Nothing
Just bench ->
let terms = callGraphBindings bindingsMap bench in
Just (hash (annM, primMapHash, show clashModDate, terms))
let manifestI = Manifest (topHash,benchHashM) [] [] [] [] []
let
manFile =
case annM of
Nothing -> hdlDir </> topNmU <.> "manifest"
_ -> hdlDir </> topNmU </> topNmU <.> "manifest"
manM <- if not (opt_cachehdl opts)
then return Nothing -- ignore manifest file because -fclash-nocache
else (>>= readMaybe) . either (const Nothing) Just <$>
tryJust (guard . isDoesNotExistError) (readFile manFile)
return (maybe (False,False,manifestI)
(\man -> (fst (manifestHash man) == topHash
,snd (manifestHash man) == benchHashM
,man {manifestHash = (topHash,benchHashM)}
))
manM)
(supplyN,supplyTB) <- Supply.splitSupply
. snd
. Supply.freshId
<$> Supply.newSupply
let topEntityNames = map (\(x,_,_) -> x) topEntities
(topTime,manifest',seen') <- if sameTopHash
then do
putStrLn ("Using cached result for: " ++ Data.Text.unpack (nameOcc (varName topEntity)))
topTime <- Clock.getCurrentTime
return (topTime,manifest,componentNames manifest ++ seen)
else do
-- 1. Normalise topEntity
let (transformedBindings,is0) = normalizeEntity reprs bindingsMap primMap tcm tupTcm
typeTrans eval topEntityNames opts supplyN
topEntity
normTime <- transformedBindings `deepseq` Clock.getCurrentTime
let prepNormDiff = Clock.diffUTCTime normTime prevTime
putStrLn $ "Normalisation took " ++ show prepNormDiff
-- 2. Generate netlist for topEntity
(netlist,seen') <-
genNetlist False opts reprs transformedBindings is0 topEntities primMap
tcm typeTrans iw mkId extId seen hdlDir prefixM topEntity
netlistTime <- netlist `deepseq` Clock.getCurrentTime
let normNetDiff = Clock.diffUTCTime netlistTime normTime
putStrLn $ "Netlist generation took " ++ show normNetDiff
-- 3. Generate topEntity wrapper
let topComponent = view _3 . head $ filter (Data.Text.isSuffixOf topNm . componentName . view _3) netlist
(hdlDocs,manifest',dfiles,mfiles) = createHDL hdlState' (Data.Text.pack modName) seen' netlist topComponent
(topNm, Right manifest)
dir = hdlDir </> maybe "" (const modName) annM
prepareDir (opt_cleanhdl opts) (extension hdlState') dir
mapM_ (writeHDL dir) hdlDocs
copyDataFiles (opt_importPaths opts) dir dfiles
writeMemoryDataFiles dir mfiles
topTime <- hdlDocs `seq` Clock.getCurrentTime
return (topTime,manifest',seen')
benchTime <- case benchM of
Just tb | not sameBenchHash -> do
putStrLn $ "Compiling: " ++ Data.Text.unpack (nameOcc (varName tb))
let modName' = genComponentName [] mkId prefixM tb
hdlState2 = setModName modName' hdlState'
-- 1. Normalise testBench
let (transformedBindings,is0) = normalizeEntity reprs bindingsMap primMap tcm tupTcm
typeTrans eval topEntityNames opts supplyTB tb
normTime <- transformedBindings `deepseq` Clock.getCurrentTime
let prepNormDiff = Clock.diffUTCTime normTime topTime
putStrLn $ "Testbench normalisation took " ++ show prepNormDiff
-- 2. Generate netlist for topEntity
(netlist,seen'') <-
genNetlist True opts reprs transformedBindings is0 topEntities primMap
tcm typeTrans iw mkId extId seen' hdlDir prefixM tb
netlistTime <- netlist `deepseq` Clock.getCurrentTime
let normNetDiff = Clock.diffUTCTime netlistTime normTime
putStrLn $ "Testbench netlist generation took " ++ show normNetDiff
-- 3. Write HDL
let (hdlDocs,_,dfiles,mfiles) = createHDL hdlState2 modName' seen'' netlist undefined
(topNm, Left manifest')
dir = hdlDir </> maybe "" t_name annM </> Data.Text.unpack modName'
prepareDir (opt_cleanhdl opts) (extension hdlState2) dir
writeHDL (hdlDir </> maybe "" t_name annM) (head hdlDocs)
mapM_ (writeHDL dir) (tail hdlDocs)
copyDataFiles (opt_importPaths opts) dir dfiles
writeMemoryDataFiles dir mfiles
hdlDocs `seq` Clock.getCurrentTime
Just tb -> do
let tb' = Data.Text.unpack (nameOcc (varName tb))
putStrLn ("Compiling: " ++ tb')
putStrLn ("Using cached result for: " ++ tb')
return topTime
Nothing -> return topTime
go benchTime seen' topEntities'
-- | Compiles blackbox functions and parses blackbox templates.
compilePrimitive
:: [FilePath]
-> FilePath
-> ResolvedPrimitive
-> IO CompiledPrimitive
compilePrimitive pkgDbs topDir (BlackBoxHaskell bbName bbGenName source) = do
let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs
-- Compile a blackbox template function or fetch it from an already compiled file.
r <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir (go source)
processHintError
(show bbGenName)
bbName
(\bbFunc -> BlackBoxHaskell bbName bbGenName (hash source, bbFunc))
r
where
qualMod = intercalate "." modNames
BlackBoxFunctionName modNames funcName = bbGenName
-- | Create directory based on base name and directory. Return path
-- of directory just created.
createDirectory'
:: FilePath
-> FilePath
-> IO FilePath
createDirectory' base sub =
let new = base </> sub in
Directory.createDirectory new >> return new
-- |
go
:: Maybe Text
-> Hint.Interpreter BlackBoxFunction
go (Just source') = do
-- Create a temporary directory with user module in it, add it to the
-- list of import direcotries, and run as if it were a "normal" compiled
-- module.
join $ Hint.liftIO $ do
tmpDir' <- getCanonicalTemporaryDirectory
withTempDirectory tmpDir' "clash-prim-compile" $ \tmpDir'' -> do
modDir <- foldM createDirectory' tmpDir'' (init modNames)
Text.writeFile (modDir </> (last modNames ++ ".hs")) source'
return $ do
-- Set import path for GHC interpreter and load module
iPaths <- (tmpDir'':) <$> Hint.get Hint.searchPath
Hint.set [Hint.searchPath Hint.:= iPaths]
Hint.loadModules [qualMod]
go Nothing
go Nothing = do
-- Either
Hint.setImports [ "Clash.Netlist.BlackBox.Types", qualMod]
Hint.unsafeInterpret funcName "BlackBoxFunction"
compilePrimitive pkgDbs topDir (BlackBox pNm tkind warnings oReg libM imps incs templ) = do
libM' <- mapM parseTempl libM
imps' <- mapM parseTempl imps
incs' <- mapM (traverse parseBB) incs
templ' <- parseBB templ
return (BlackBox pNm tkind warnings oReg libM' imps' incs' templ')
where
interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs
parseTempl :: Applicative m => Text -> m BlackBoxTemplate
parseTempl t = case runParse t of
Failure errInfo
-> error (ANSI.displayS (ANSI.renderCompact (_errDoc errInfo)) "")
Success t'
-> pure t'
parseBB :: ((TemplateFormat,BlackBoxFunctionName),Maybe Text) -> IO BlackBox
parseBB ((TTemplate,_),Just t) = BBTemplate <$> parseTempl t
parseBB ((TTemplate,_),Nothing) =
error ("No template specified for blackbox: " ++ show pNm)
parseBB ((THaskell,bbGenName),Just source) = do
let BlackBoxFunctionName modNames funcName = bbGenName
qualMod = intercalate "." modNames
tmpDir <- getCanonicalTemporaryDirectory
r <- withTempDirectory tmpDir "clash-prim-compile" $ \tmpDir' -> do
let modDir = foldl (</>) tmpDir' (init modNames)
Directory.createDirectoryIfMissing True modDir
Text.writeFile (modDir </> last modNames <.> "hs") source
Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do
iPaths <- (tmpDir':) <$> Hint.get Hint.searchPath
Hint.set [Hint.searchPath Hint.:= iPaths]
Hint.loadModules [qualMod]
Hint.setImports [ "Clash.Netlist.Types" , qualMod ]
Hint.unsafeInterpret funcName "TemplateFunction"
let hsh = hash (qualMod, source)
processHintError (show bbGenName) pNm (BBFunction (Data.Text.unpack pNm) hsh) r
parseBB ((THaskell,bbGenName),Nothing) = do
let BlackBoxFunctionName modNames funcName = bbGenName
qualMod = intercalate "." modNames
hsh = hash qualMod
r <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do
Hint.setImports [ "Clash.Netlist.Types" , qualMod ]
Hint.unsafeInterpret funcName "TemplateFunction"
processHintError (show bbGenName) pNm (BBFunction (Data.Text.unpack pNm) hsh) r
compilePrimitive _ _ (Primitive pNm typ) =
return $ Primitive pNm typ
processHintError
:: Monad m
=> String
-> Data.Text.Text
-> (t -> r)
-> Either Hint.InterpreterError t
-> m r
processHintError fun bb go r = case r of
Left (Hint.GhcException err) ->
error' "GHC Exception" err
Left (Hint.NotAllowed err) ->
error' "NotAllowed error" err
Left (Hint.UnknownError err) ->
error' "an unknown error" err
Left (Hint.WontCompile ghcErrs) ->
error' "compilation errors" (intercalate "\n\n" $ map Hint.errMsg ghcErrs)
Right f ->
return $ go f
where
error' errType report =
error $ unwords [ "Encountered", errType, "while compiling blackbox template"
, "function", show fun, "for function", show bb ++ "."
, "Compilation reported: \n\n" ++ report ]
-- | Pretty print Components to HDL Documents
createHDL
:: Backend backend
=> backend
-- ^ Backend
-> Identifier
-- ^ Module hierarchy root
-> [Identifier]
-- ^ Component names
-> [(SrcSpan,[Identifier],Component)]
-- ^ List of components
-> Component
-- ^ Top component
-> (Identifier, Either Manifest Manifest)
-- ^ Name of the manifest file
-- + Either:
-- * Left manifest: Only write/update the hashes of the @manifest@
-- * Right manifest: Update all fields of the @manifest@
-> ([(String,Doc)],Manifest,[(String,FilePath)],[(String,String)])
-- ^ The pretty-printed HDL documents
-- + The update manifest file
-- + The data files that need to be copied
createHDL backend modName seen components top (topName,manifestE) = flip evalState backend $ getMon $ do
(hdlNmDocs,incs) <- unzip <$> mapM (\(sp,ids,comp) -> genHDL modName sp (seen ++ ids) comp) components
hwtys <- HashSet.toList <$> extractTypes <$> Mon get
typesPkg <- mkTyPackage modName hwtys
dataFiles <- Mon getDataFiles
memFiles <- Mon getMemoryDataFiles
let hdl = map (first (<.> Clash.Backend.extension backend)) (typesPkg ++ hdlNmDocs)
qincs = concat incs
topFiles = hdl ++ qincs
manifest <- either return (\m -> do
let topInNames = map fst (inputs top)
topInTypes <- mapM (fmap (Text.toStrict . renderOneLine) .
hdlType (External topName) . snd) (inputs top)
let topOutNames = map (fst . snd) (outputs top)
topOutTypes <- mapM (fmap (Text.toStrict . renderOneLine) .
hdlType (External topName) . snd . snd) (outputs top)
let compNames = map (componentName . view _3) components
return (m { portInNames = topInNames
, portInTypes = topInTypes
, portOutNames = topOutNames
, portOutTypes = topOutTypes
, componentNames = compNames
})
) manifestE
let manDoc = ( Data.Text.unpack topName <.> "manifest"
, pretty (Text.pack (show manifest)))
return (manDoc:topFiles,manifest,dataFiles,memFiles)
-- | Prepares the directory for writing HDL files. This means creating the
-- dir if it does not exist and removing all existing .hdl files from it.
prepareDir :: Bool -- ^ Remove existing HDL files
-> String -- ^ File extension of the HDL files.
-> String
-> IO ()
prepareDir cleanhdl ext dir = do
-- Create the dir if needed
Directory.createDirectoryIfMissing True dir
-- Clean the directory when needed
when cleanhdl $ do
-- Find all HDL files in the directory
files <- Directory.getDirectoryContents dir
let to_remove = filter ((==ext) . FilePath.takeExtension) files
-- Prepend the dirname to the filenames
let abs_to_remove = map (FilePath.combine dir) to_remove
-- Remove the files
mapM_ Directory.removeFile abs_to_remove
-- | Writes a HDL file to the given directory
writeHDL :: FilePath -> (String, Doc) -> IO ()
writeHDL dir (cname, hdl) = do
let rendered = renderLazy (layoutPretty (LayoutOptions (AvailablePerLine 120 0.4)) hdl)
-- remove blank lines to keep things clean
clean = Text.unlines
. map (\t -> if Text.all (==' ') t then Text.empty else t)
. Text.lines
bracket (IO.openFile (dir </> cname) IO.WriteMode) IO.hClose $ \h -> do
Text.hPutStr h (clean rendered)
Text.hPutStr h (Text.pack "\n")
-- | Copy given files
writeMemoryDataFiles
:: FilePath
-- ^ Directory to copy files to
-> [(String, String)]
-- ^ (filename, content)
-> IO ()
writeMemoryDataFiles dir files =
mapM_
(uncurry writeFile)
[(dir </> fname, content) | (fname, content) <- files]
copyDataFiles
:: [FilePath]
-> FilePath
-> [(String,FilePath)]
-> IO ()
copyDataFiles idirs dir = mapM_ (copyFile' idirs)
where
copyFile' dirs (nm,old) = do
oldExists <- Directory.doesFileExist old
if oldExists
then Directory.copyFile old new
else goImports dirs
where
new = dir FilePath.</> nm
goImports [] = do
oldExists <- Directory.doesFileExist old
if oldExists
then Directory.copyFile old new
else unless (null old) (putStrLn ("WARNING: file " ++ show old ++ " does not exist"))
goImports (d:ds) = do
let old2 = d FilePath.</> old
old2Exists <- Directory.doesFileExist old2
if old2Exists
then Directory.copyFile old2 new
else goImports ds
-- | Get all the terms corresponding to a call graph
callGraphBindings
:: BindingMap
-- ^ All bindings
-> Id
-- ^ Root of the call graph
-> [Term]
callGraphBindings bindingsMap tm =
map ((^. _4) . (bindingsMap `lookupUniqMap'`)) (keysUniqMap cg)
where
cg = callGraph bindingsMap tm
-- | Normalize a complete hierarchy
normalizeEntity
:: CustomReprs
-> BindingMap
-- ^ All bindings
-> CompiledPrimMap
-- ^ BlackBox HDL templates
-> TyConMap
-- ^ TyCon cache
-> IntMap TyConName
-- ^ Tuple TyCon cache
-> (CustomReprs -> TyConMap -> Bool -> Type -> Maybe (Either String HWType))
-- ^ Hardcoded 'Type' -> 'HWType' translator
-> PrimEvaluator
-- ^ Hardcoded evaluator (delta-reduction)
-> [Id]
-- ^ TopEntities
-> ClashOpts
-- ^ Debug information level for the normalization process
-> Supply.Supply
-- ^ Unique supply
-> Id
-- ^ root of the hierarchy
-> (BindingMap, InScopeSet)
normalizeEntity reprs bindingsMap primMap tcm tupTcm typeTrans eval topEntities
opts supply tm = transformedBindings
where
doNorm = do norm <- normalize [tm]
let normChecked = checkNonRecursive norm
cleaned <- cleanupGraph tm normChecked
is0 <- use globalInScope
return (cleaned,is0)
transformedBindings = runNormalization opts supply bindingsMap
typeTrans reprs tcm tupTcm eval primMap emptyVarEnv
topEntities doNorm