forked from B-Lang-org/bsc
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathISyntax.hs
1580 lines (1364 loc) · 62.6 KB
/
ISyntax.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
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
module ISyntax(
IPackage(..),
IDef(..),
IKind(..),
IType(..),
IExpr(..),
ConTagInfo(..),
IConInfo(..),
IRules(..),
IRule(..),
IEFace(..),
IModule(..),
IAbstractInput(..),
IStateVar(..),
PortTypeMap,
IClock,
IReset,
IInout,
ILazyArray,
ArrayCell(..),
Pred(..),
PTerm(..),
getClockMap,
getResetMap,
getVModInfo,
iRUnion,
iRUnionPreempt,
iRUnionUrgency,
iRUnionExecutionOrder,
iRUnionMutuallyExclusive,
iRUnionConflictFree,
iREmpty,
uniquifyRules,
fdVars,
normITAp,
splitITAp,
aTVars,
itArrow,
iToCT,
iToCK,
tSubst,
eSubst,
etSubst,
iAp,
iAP,
fVars,
ftVars,
mkNumConT,
showTypeless,
showTypelessRules,
getIExprPosition,
getITypePosition,
getIExprPositionCross,
-- getITypePositionCross,
getIRuleId,
getIRuleStateLoc,
sameClockDomain,
inClockDomain,
getClockDomain,
isNoClock,
isMissingDefaultClock,
makeClock,
getClockWires,
setClockWires,
makeReset,
getResetWire,
getResetClock,
getResetId,
isNoReset,
isMissingDefaultReset,
makeInout,
getInoutWire,
getInoutClock,
getInoutReset,
getWireInfo,
isIConInt, isIConReal, isIConParam
) where
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
import Prelude hiding ((<>))
#endif
import System.IO(Handle)
import qualified Data.Map as M
import Data.List(intercalate)
import qualified Data.Array as Array
import IntLit
import Undefined
import Eval
import Id
import Wires(ResetId, ClockDomain, ClockId, noClockId, noResetId, noDefaultClockId, noDefaultResetId, WireProps)
import IdPrint
import PreIds(idSizeOf, idId, idBind, idReturn, idPack, idUnpack, idMonad, idLiftModule, idBit, idFromInteger, idTNumToStr)
import Backend
import Prim(PrimOp(..))
import TypeOps
import ConTagInfo
import VModInfo(VModInfo, vArgs, vName, VName(..), {- VeriPortProp(..), -}
VArgInfo(..), VFieldInfo(..), isParam, VWireInfo)
import Pragma(Pragma, PProp, RulePragma, ISchedulePragma,
CSchedulePragma, SchedulePragma(..), DefProp,
extractSchedPragmaIds, removeSchedPragmaIds, mapSPIds)
import Position
import Data.Maybe
import FStringCompat(mkNumFString)
import qualified Data.Set as S
import Flags
import Error(internalError, EMsg, ErrMsg(..))
import PFPrint
import IStateLoc(IStateLoc)
import IType
import qualified Data.Generics as Generic
-- ============================================================
-- IPackage, IModule
-- A package of top-level definitions and pragmas
-- * This corresponds to a .bo file.
-- * During iExpand, top-level defs for modules are synthesized
-- and those defs are replaceds with new defs that are merely
-- import-BVI of the generated module.
--
data IPackage a
= IPackage {
-- package name
ipkg_name :: Id,
-- linked packages (name, signature)
ipkg_depends :: [(Id, String)],
-- pragmas
ipkg_pragmas :: [Pragma],
-- definition list
ipkg_defs :: [IDef a]
}
deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable)
-- An elaborated module
-- * These are created during iExpand for each module to be synthesized
-- from the IPackage.
data IModule a
= IModule {
imod_name :: Id, -- module name
imod_is_wrapped :: Bool, -- function wrapper?
imod_backend_specifc :: Maybe Backend,
imod_external_wires :: VWireInfo, -- boundary wire information (clock, reset, arguments, etc.)
imod_pragmas :: [Pragma], -- all top level pragmas
-- XXX The list of type args is always empty (unused).
-- If we supported generation of modules with numeric type
-- variables, they would be in this list.
imod_type_args :: [(Id, IKind)], -- package type arguments
imod_wire_args :: [IAbstractInput], -- package (wire) arguments
imod_clock_domains :: [(ClockDomain, [IClock a])], -- clocks (internal and external)
imod_resets :: [IReset a], -- resets (internal and external)
imod_state_insts :: [(Id, IStateVar a)], -- state elements
imod_port_types :: PortTypeMap, -- map from state variable -> port -> source type
imod_local_defs :: [IDef a], -- local definitions
imod_rules :: IRules a, -- rules
imod_interface :: [IEFace a], -- package interface
imod_ffcallNo :: Int, -- next available unique ffcalNo
-- comments on submodule instantiations
imod_instance_comments :: [(Id, [String])]
}
deriving (Show, Generic.Data, Generic.Typeable)
getWireInfo :: IModule a -> VWireInfo
getWireInfo = imod_external_wires
-- Map from submod instance name to a map from port to its source type.
-- Toplevel ports of the current module are represented in the same map
-- using the Nothing value in place of an instance name.
type PortTypeMap = M.Map (Maybe Id) (M.Map VName IType)
data IDef a = IDef Id IType (IExpr a) [DefProp]
deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable)
data IAbstractInput =
-- simple input using one port
IAI_Port (Id, IType) |
-- clock osc and maybe gate
IAI_Clock Id (Maybe Id) |
IAI_Reset Id |
IAI_Inout Id Integer
-- room to add other types here, like:
-- IAI_Struct [(Id, IType)]
deriving (Eq, Show, Generic.Data, Generic.Typeable)
data IEFace a = IEFace {
-- This is either an actual method or a ready signal for another
-- method. Use 'isRdyId' to determine which. Use 'mkRdyId' on
-- the name of an actual method to construct the name of its
-- associated ready method.
ief_name :: Id,
-- arguments
ief_args :: [(Id, IType)],
-- Prior to 'iSplitIface', 'ief_value' contains the expression for
-- the whole method and 'ief_body' is empty. After 'iSplitIface',
-- 'ief_value' contains the return value (if any) and 'ief_body'
-- contains the rules (the Actions) (if any).
-- XXX Should we use a different type for these two forms?
ief_value :: (Maybe (IExpr a, IType)),
ief_body :: (Maybe (IRules a)),
ief_wireprops :: WireProps,
ief_fieldinfo :: VFieldInfo
}
deriving (Show, Generic.Data, Generic.Typeable)
-- ---------------
-- IStateVar
-- a state variable (foreign module instantiation)
data IStateVar a = IStateVar {
isv_is_arg :: Bool, -- real state variable (or argument)
isv_is_user_import :: Bool, -- whether it is a foreign module
isv_uid :: Int, -- unique number
isv_vmi :: VModInfo, -- foreign module info
isv_iargs :: [IExpr a], -- params + arguments
isv_type :: IType, -- type of the svar (like "Prelude.VReg")
-- The next list corresponds to vFields in the VModInfo, but cannot be
-- stored there, because VModInfo is created before types are known:
isv_meth_types :: [[IType]], -- method types
isv_clocks :: [(Id, IClock a)], -- named clocks
isv_resets :: [(Id, IReset a)], -- named resets
isv_isloc :: IStateLoc -- instantiation path
}
deriving (Show, Generic.Data, Generic.Typeable)
getResetMap :: IStateVar a -> [(Id, IReset a)]
getResetMap = isv_resets
getClockMap :: IStateVar a -> [(Id, IClock a)]
getClockMap = isv_clocks
getVModInfo :: IStateVar a -> VModInfo
getVModInfo = isv_vmi
instance Eq (IStateVar a) where
a == b = isv_uid a == isv_uid b
instance Ord (IStateVar a) where
a `compare` b = isv_uid a `compare` isv_uid b
-- ==============================
-- IRule
-- last Id is original rule if rule has been split, Nothing otherwise
-- (argument descriptions are guesses based on ARule)
data IRule a =
IRule {
-- rule name
irule_name :: Id,
-- rule pragmas, e.g., no-implicit-conditions
irule_pragmas :: [RulePragma],
-- String that describes the rule
irule_description :: String,
-- Rule wire properties
irule_wire_properties :: WireProps,
-- Rule predicate
irule_pred :: (IExpr a),
-- Rule body
irule_body :: (IExpr a),
{- orig rule - for splitting -}
irule_original :: (Maybe Id),
-- Instantiation hierarchy
irule_state_loc :: IStateLoc
}
deriving (Show, Generic.Data, Generic.Typeable)
instance Hyper (IRule a) where
hyper (IRule i ps s wp r1 r2 orig isl) y = hyper8 i ps s wp r1 r2 orig isl y
getIRuleId :: IRule a -> Id
getIRuleId = irule_name
getIRuleStateLoc :: IRule a -> IStateLoc
getIRuleStateLoc = irule_state_loc
data IRules a = IRules [ISchedulePragma] [IRule a]
deriving (Show, Generic.Data, Generic.Typeable)
instance Hyper (IRules a) where
hyper (IRules sps rs) y = hyper2 sps rs y
-- renames the rules according to the Id,Id list
renameIRules :: [(Id,Id)] -> IRules a -> IRules a
renameIRules [] rls = rls
renameIRules idmap rls@(IRules schedPara rules) = IRules newSchedPara newRules
where
newRules = map (renameIRule idmap) rules
newSchedPara = mapSPIds (renameFromMap idmap) schedPara -- map (renameSchedPara idmap) schedPara
renameIRule :: [(Id,Id)] -> IRule a -> IRule a
renameIRule idmap orig = newRule
where
newId = lookup (irule_name orig) idmap
newRule = if ( isNothing newId )
then orig
else orig {irule_name = (fromJust newId)}
renameFromMap :: (Eq a) => [(a,a)] -> a -> a
renameFromMap idmap id = fromMaybe id newId
where
newId = lookup id idmap
-- Return a new second set of rules, with names changed to not clash
-- with a first set of rules
uniquifyRules :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a)
uniquifyRules flags suf r1@(IRules _ rs1) r2@(IRules sps2 rs2) =
if (ruleNameCheck flags)
then let rids1 = map getIRuleId rs1
rids2 = map getIRuleId rs2
-- rename the rules in r2 if needed
(_, idmap) = genUniqueIdsAndMap rids1 rids2
in (suf, renameIRules idmap r2)
else let fn r (n, m, rs) = let oldname = irule_name r
(basename, _) = stripId_Suffix oldname
newname = addId_Suffix basename n
r' = r { irule_name = newname }
m' = ((oldname,newname):m)
in (n+1, m', r':rs)
(suf', idmap, rs2') = foldr fn (suf, [], []) rs2
sps2' = mapSPIds (renameFromMap idmap) sps2
in (suf', IRules sps2' rs2')
iRUnion :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnion flags suf r1@(IRules _ rs1) r2 =
let (suf', r2_unique@(IRules _ rs2)) = uniquifyRules flags suf r1 r2
(errs, sps) = checkRUnionAttributes r1 r2_unique
in (suf', IRules sps (rs1 ++ rs2), errs)
iRUnionPreempt :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnionPreempt flags suf r1@(IRules _ rs1) r2 =
let (suf', r2_unique@(IRules _ rs2)) = uniquifyRules flags suf r1 r2
(errs, sps) = checkRUnionAttributes r1 r2_unique
sps3 = [SPPreempt (map getIRuleId rs1) (map getIRuleId rs2)]
in (suf', IRules (sps3 ++ sps) (rs1 ++ rs2), errs)
iRUnionUrgency :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnionUrgency flags suf r1@(IRules _ rs1) r2 =
let (suf', r2_unique@(IRules _ rs2)) = uniquifyRules flags suf r1 r2
(errs, sps) = checkRUnionAttributes r1 r2_unique
sps3 = [ SPUrgency [rid1, rid2]
| rid1 <- map getIRuleId rs1,
rid2 <- map getIRuleId rs2 ]
in (suf', IRules (sps3 ++ sps) (rs1 ++ rs2), errs)
iRUnionExecutionOrder :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnionExecutionOrder flags suf r1@(IRules _ rs1) r2 =
let (suf', r2_unique@(IRules _ rs2)) = uniquifyRules flags suf r1 r2
(errs, sps) = checkRUnionAttributes r1 r2_unique
sps3 = [ SPExecutionOrder [rid1, rid2]
| rid1 <- map getIRuleId rs1,
rid2 <- map getIRuleId rs2 ]
in (suf', IRules (sps3 ++ sps) (rs1 ++ rs2), errs)
iRUnionPairwiseSchedPragma :: Flags -> Integer
-> ([[Id]] -> ISchedulePragma)
-> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnionPairwiseSchedPragma flags suf sched_pragma r1@(IRules _ rs1) r2 =
let (suf', r2_unique@(IRules _ rs2)) = uniquifyRules flags suf r1 r2
(errs, sps) = checkRUnionAttributes r1 r2_unique
sps3 = [sched_pragma [ map getIRuleId rs1, map getIRuleId rs2 ]]
in (suf', IRules (sps3 ++ sps) (rs1 ++ rs2), errs)
iRUnionMutuallyExclusive :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnionMutuallyExclusive flags suf r1 r2 =
iRUnionPairwiseSchedPragma flags suf SPMutuallyExclusive r1 r2
iRUnionConflictFree :: Flags -> Integer -> IRules a -> IRules a -> (Integer, IRules a, [EMsg])
iRUnionConflictFree flags suf r1 r2 =
-- trace "iRUnionConflictFree" $
iRUnionPairwiseSchedPragma flags suf SPConflictFree r1 r2
iREmpty :: IRules a
iREmpty = IRules [] []
-- Check that all rule attribute are defined in the given (joined) rules
-- XXX Is that the behavior we want?
-- Return the pragmas with the bad names filtered out
checkRUnionAttributes :: IRules a -> IRules a -> ([EMsg], [ISchedulePragma])
checkRUnionAttributes (IRules sps1 rs1) (IRules sps2 rs2) =
let
definedIds = map getIRuleId rs1 ++ map getIRuleId rs2
attrIds = extractSchedPragmaIds (sps1 ++ sps2)
testMap = M.fromList $ zip definedIds (repeat (0 :: Int ))
checkMap = M.fromList $ zip attrIds (repeat (0 :: Int ))
badIds :: [Id]
badIds = map fst $ M.toList $ M.difference checkMap testMap
mkErr i = (getIdPosition i, EUnknownRuleIdAttribute (pfpString i))
msgs = map mkErr badIds
sps' = if (null badIds)
then sps1 ++ sps2
else removeSchedPragmaIds badIds (sps1 ++ sps2)
in
(msgs, sps')
tSubst :: Id -> IType -> IType -> IType
tSubst v x t = sub t
where sub tt@(ITForAll i k t)
| v == i = tt
| i `S.member` fvx =
let i' = cloneId (S.toList vs) i
t' = tSubst i (ITVar i') t
in ITForAll i' k (sub t')
| otherwise = ITForAll i k (sub t)
sub (ITAp f a) = normITAp (sub f) (sub a)
sub tt@(ITVar i) = if i == v then x else tt
sub tt@(ITCon _ _ _) = tt
sub tt@(ITNum _) = tt
sub tt@(ITStr _) = tt
fvx = fTVars' x
vs = fvx `S.union` aTVars' t
normITAp :: IType -> IType -> IType
normITAp (ITAp (ITCon op _ _) (ITNum x)) (ITNum y) | isJust (res) =
mkNumConT (fromJust res)
where res = opNumT op [x, y]
normITAp (ITCon op _ _) (ITNum x) | isJust (res) =
mkNumConT (fromJust res)
where res = opNumT op [x]
normITAp (ITAp (ITCon op _ _) (ITStr x)) (ITStr y) | isJust (res) =
ITStr (fromJust res)
where res = opStrT op [x, y]
normITAp (ITCon op _ _) (ITNum x) | op == idTNumToStr =
ITStr (mkNumFString x)
normITAp f@(ITCon op _ _) a | op == idSizeOf && notVar a =
-- trace ("normITAp: " ++ ppReadable (ITAp f a)) $
ITAp f a
where notVar (ITVar _) = False
notVar _ = True
normITAp f@(ITCon op _ _) a | op == idId = a
normITAp f a = ITAp f a
aTVars :: IType -> [Id]
aTVars t = S.toList (aTVars' t)
aTVars' :: IType -> S.Set Id
aTVars' (ITForAll i _ t) = S.insert i (aTVars' t)
aTVars' (ITAp f a) = (aTVars' f) `S.union` (aTVars' a)
aTVars' (ITVar i) = S.singleton i
aTVars' (ITCon _ _ _) = S.empty
aTVars' (ITNum _) = S.empty
aTVars' (ITStr _) = S.empty
-- fTVars :: IType -> [Id]
-- fTVars t = S.toList (fTVars' t)
fTVars' :: IType -> S.Set Id
fTVars' (ITForAll i _ t) = S.delete i (fTVars' t)
fTVars' (ITAp f a) = fTVars' f `S.union` fTVars' a
fTVars' (ITVar i) = S.singleton i
fTVars' (ITCon _ _ _) = S.empty
fTVars' (ITNum _) = S.empty
fTVars' (ITStr _) = S.empty
splitITAp :: IType -> (IType, [IType])
splitITAp (ITAp f a) = let (l, as) = splitITAp f
in (l, as ++ [a])
splitITAp t = (t, [])
-- ==============================
-- IExpr
-- a is a placeholder type for the actual data stored in heap cells
-- so that all things that work on generic IExprs do not touch the heap
-- and to prevent exposing evaluator implementation details in ISyntax
data IExpr a
= ILam Id IType (IExpr a) -- vanishes after IExpand
| IAps (IExpr a) [IType] [IExpr a]
| IVar Id -- vanishes after IExpand
| ILAM Id IKind (IExpr a) -- vanishes after IExpand
| ICon Id (IConInfo a)
-- IRef is only used during reduction, it refers to a "heap" cell
| IRefT IType !Int a -- vanishes after IExpand
deriving (Generic.Data, Generic.Typeable)
instance Show (IExpr a) where
show (ILam i t e) = "(ILam " ++ show i ++ " " ++ show t ++ " " ++ show e ++ ")"
show (IAps f ts es) = "(IAps " ++ show f ++ " " ++ show ts ++ " " ++ show es ++ ")"
show (IVar i) = "(IVar " ++ show i ++ ")"
show (ILAM i k e) = "(ILAM " ++ show i ++ " " ++ show k ++ " " ++ show e ++ ")"
show (ICon i ic) = "(ICon " ++ show i ++ " " ++ show ic ++ ")"
show (IRefT t p _) = "(IRefT " ++ show t ++ " " ++ "_" ++ show p ++ ")"
cmpE :: IExpr a -> IExpr a -> Ordering
cmpE (ILam i1 _ e1) (ILam i2 _ e2) =
case compare i1 i2 of
EQ -> cmpE e1 e2
o -> o
cmpE (ILam _ _ _) _ = LT
cmpE (IAps _ _ _) (ILam _ _ _) = GT
cmpE (IAps e1 ts1 es1) (IAps e2 ts2 es2) =
case compare e1 e2 of
EQ ->
case compare es1 es2 of
EQ -> compare ts1 ts2
o -> o
{-
case compare ts1 ts2 of
EQ -> compare es1 es2
o -> o
-}
o -> o
cmpE (IAps _ _ _) _ = LT
cmpE (IVar _) (ILam _ _ _) = GT
cmpE (IVar _) (IAps _ _ _) = GT
cmpE (IVar i1) (IVar i2) = compare i1 i2
cmpE (IVar _) _ = LT
cmpE (ILAM _ _ _) (ILam _ _ _) = GT
cmpE (ILAM _ _ _) (IAps _ _ _) = GT
cmpE (ILAM _ _ _) (IVar _) = GT
cmpE (ILAM i1 _ e1) (ILAM i2 _ e2) =
case compare i1 i2 of
EQ -> cmpE e1 e2
o -> o
cmpE (ILAM _ _ _) (IRefT _ _ _) = GT -- ???????
cmpE (ILAM _ _ _) _ = LT
cmpE (ICon _ _) (ILam _ _ _) = GT
cmpE (ICon _ _) (IAps _ _ _) = GT
cmpE (ICon _ _) (IVar _) = GT
cmpE (ICon i1 ic1) (ICon i2 ic2) =
case compare i1 i2 of
EQ -> case (cmpC ic1 ic2) of
-- inlined positions need to be considered in equality tests
EQ -> let mposs1 = getIdInlinedPositions i1
mposs2 = getIdInlinedPositions i2
in compare mposs1 mposs2
o -> o
o -> o
cmpE (ICon _ _) _ = LT
cmpE (IRefT _ _ _) (ILam _ _ _) = GT
cmpE (IRefT _ _ _) (IAps _ _ _) = GT
cmpE (IRefT _ _ _) (IVar _) = GT
cmpE (IRefT _ _ _) (ICon _ _) = GT
cmpE (IRefT _ p1 _) (IRefT _ p2 _) = compare p1 p2 -- XXX
cmpE (IRefT _ _ _) (ILAM _ _ _) = LT -- ??????????
{- all cases are covered above, so the compiler complains about this line:
cmpE e1 e2 = internalError ("not match in cmpE " ++ ppReadable (e1,e2))
-}
instance Eq (IExpr a) where
x == y = cmpE x y == EQ
x /= y = cmpE x y /= EQ
instance Ord (IExpr a) where
compare x y = cmpE x y
-- ==============================
-- IClock
-- ISyntax clocks
data IClock a = IClock { ic_id :: ClockId, -- unique id
ic_domain :: ClockDomain, -- unique id for clock "family"
ic_wires :: IExpr a -- expression for clock wires
-- will be ICSel of (ICStateVar) or ICTuple of ICModPorts / ICInt (1) for ungated clocks
-- theoretically ICTuple (ICInt (0), ICInt (0)) for noClock, but should not appear
} deriving (Generic.Data, Generic.Typeable)
-- break recursion of wires so that showing a clock does not loop
instance Show (IClock a) where
show (IClock clockid domain wires) = "IClock id: " ++ (show clockid) ++ " domain: " ++ (show domain) ++ " " ++ (ppString wires)
-- simple instance for now
instance PPrint (IClock a) where
pPrint p d c = text (show c)
instance Eq (IClock a) where
IClock {ic_id = x} == IClock {ic_id = y} = x == y
instance Ord (IClock a) where
IClock {ic_id = x} `compare` IClock {ic_id = y} = x `compare` y
instance Hyper (IClock a) where
-- XXX clock wires can be recursive (so just hyper id)
hyper c y = (c==c) `seq` y
makeClock :: ClockId -> ClockDomain -> IExpr a -> IClock a
makeClock clockid domain wires = IClock { ic_id = clockid,
ic_domain = domain,
ic_wires = wires }
getClockWires :: IClock a -> IExpr a
getClockWires = ic_wires
-- used to implement primReplaceClockGate
setClockWires :: IClock a -> IExpr a -> IClock a
setClockWires ic e = ic { ic_wires = e }
getClockDomain :: IClock a -> ClockDomain
getClockDomain = ic_domain
-- noClock value defined in ISyntaxUtil
isNoClock :: IClock a -> Bool
isNoClock IClock {ic_id = clockid} = clockid == noClockId
--
isMissingDefaultClock :: IClock a -> Bool
isMissingDefaultClock (IClock {ic_id = clockid}) = clockid == noDefaultClockId
sameClockDomain :: IClock a -> IClock a -> Bool
sameClockDomain (IClock {ic_domain = d1}) (IClock {ic_domain = d2}) = d1 == d2
inClockDomain :: ClockDomain -> IClock a -> Bool
inClockDomain d (IClock {ic_domain = d'}) = d == d'
-- ==============================
-- IReset
-- ISyntax resets
-- XXX this will change as reset is more fully implemented
data IReset a = IReset { ir_id :: ResetId, -- unique id
ir_clock :: IClock a, -- associated clock (may be noClock)
-- reset_sync :: Bool, -- synchronous or asynchronous
ir_wire :: IExpr a -- expression for reset wire
-- currently must be an ICModPort or 0,
-- since we do not support reset output
} deriving (Generic.Data, Generic.Typeable)
-- must break recursion of wire so showing a reset output does not loop
instance Show (IReset a) where
show (IReset resetid clock wire) = "IReset id: " ++ (show resetid) ++ " clock: " ++ (show clock) ++ " " ++ (ppString wire)
-- simple instance for now
instance PPrint (IReset a) where
pPrint p d r = text (show r)
instance Eq (IReset a) where
IReset {ir_id = x} == IReset {ir_id = y} = x == y
instance Ord (IReset a) where
IReset {ir_id = x} `compare` IReset {ir_id = y} = x `compare` y
instance Hyper (IReset a) where
-- XXX reset wires can be recursive (so just hyper id)
hyper r y = (r==r) `seq` y
makeReset :: ResetId -> IClock a -> IExpr a -> IReset a
makeReset i c w = IReset { ir_id = i, ir_clock = c, ir_wire = w }
getResetWire :: IReset a -> IExpr a
getResetWire = ir_wire
getResetClock :: IReset a -> IClock a
getResetClock = ir_clock
getResetId :: IReset a -> ResetId
getResetId = ir_id
-- noReset defined in ISyntaxUtil (like noClock)
isNoReset :: IReset a -> Bool
isNoReset IReset { ir_id = i } = i == noResetId
isMissingDefaultReset :: IReset a -> Bool
isMissingDefaultReset (IReset { ir_id = i }) = i == noDefaultResetId
-- ==============================
-- IInout
data IInout a =
IInout { io_clock :: IClock a, -- associated clock (may be noClock)
io_reset :: IReset a, -- associated reset (may be noReset)
io_wire :: IExpr a -- expression for inout wire
} deriving (Generic.Data, Generic.Typeable)
instance Show (IInout a) where
show (IInout clock reset wire) =
"IInout clock: " ++ show clock ++ " reset: " ++ show reset ++
" |" ++ ppReadable wire ++ "|"
instance PPrint (IInout a) where
pPrint p d r@IInout { io_wire = wire } = pPrint p d wire
instance Hyper (IInout a) where
-- XXX wires be recursive, so just check the other parts
hyper (IInout c r w) y = (c==c) `seq` (r==r) `seq` y
makeInout :: IClock a -> IReset a -> IExpr a -> IInout a
makeInout c r w = IInout { io_clock = c, io_reset = r, io_wire = w }
getInoutClock :: IInout a -> IClock a
getInoutClock = io_clock
getInoutReset :: IInout a -> IReset a
getInoutReset = io_reset
getInoutWire :: IInout a -> IExpr a
getInoutWire = io_wire
-- ==============================
-- Primitive Arrays
-- We guarantee that ICLazyArray elements are references during IExpand,
-- using this type for the elements.
-- This ensures that the equality check in "improveIf" is inexpensive.
-- After IExpand, we can't have heap refs anymore, so we convert ICLazyArray
-- into application of PrimBuildArray to the element expressions.
--
data ArrayCell a = ArrayCell { ac_ptr :: Int, ac_ref :: a }
deriving (Generic.Data, Generic.Typeable)
instance Show (ArrayCell a) where
show (ArrayCell i _) = "_" ++ show i
{-
instance Hyper (ArrayCell a) where
hyper (ArrayCell i _) y = hyper i y
-}
type ILazyArray a = Array.Array Integer (ArrayCell a)
instance Hyper (ILazyArray a) where
-- XXX causes cycles somehow
-- hyper arr y = hyper (Array.accum hyper arr []) y
hyper arr y = y
-- ==============================
-- Pred
-- Predicates used for implicit conditions.
-- most utility functions in IExpandUtils
newtype Pred a = PConj (PSet (PTerm a))
deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable)
instance PPrint (Pred a) where
pPrint d p (PConj ps) = pPrint d p (S.toList ps)
instance PPrint (PTerm a) where
pPrint d p (PAtom e) = pPrint d p e
pPrint d p (PIf c t e) = text "PIf(" <> sepList [pPrint d 0 c, pPrint d 0 t, pPrint d 0 e] (text ",") <> text ")"
pPrint d p (PSel idx _ es) = text "PSel(" <> sepList (pPrint d 0 idx : map (pPrint d 0) es) (text ",") <> text ")"
instance Hyper (Pred a) where
-- XXX - see if we can get away with not forcing
-- the internal Pred structure
-- worried about Array/Reset/Clock-like issues
hyper p y = y
type PSet a = S.Set a
data PTerm a = PAtom (IExpr a)
| PIf (IExpr a) (Pred a) (Pred a)
| PSel (IExpr a) Integer [Pred a]
deriving (Eq, Ord, Show, Generic.Data, Generic.Typeable)
-- ==============================
-- IConInfo
data IConInfo a =
-- top level definition
-- iconDef has the definition body
-- may be _ if the ICDef was read from a .bo file and has not been fixed-up yet
-- these disappear in IExpand and do not exists in IModule
ICDef { iConType :: IType, iConDef :: IExpr a }
| ICPrim { iConType :: IType, primOp :: PrimOp } -- primitive
-- foreign function; foports specifies input and output port names in verilog
-- (for functions implemented via module instantiation - primarily "noinlined")
-- Nothing in foports indicates this is a "true" foreign function
-- (positional module instantiation is no longer supported)
-- fcallNo is a cookie used to mark foreign function calls during elaboration
-- so an association can be made between the Action and Value parts of an
-- ActionValue call (e.g. $fopen or $stime) for use deep in the output codegens
| ICForeign { iConType :: IType,
fName :: String,
isC :: Bool,
foports :: Maybe ([(String, Integer)], [(String, Integer)]),
fcallNo :: Maybe Integer }
-- constructor
| ICCon { iConType :: IType, conTagInfo :: ConTagInfo }
-- function that tests whether its argument is the right kind of a constructor
-- eventually cancels out and turns into ICInt 0 (false) or 1 (true)
| ICIs { iConType :: IType, conTagInfo :: ConTagInfo }
-- function that projects the data associated with a particular constructor
-- only used after doing appropriate ICIs, otherwise turns into _,
-- which is "convenient for some transformations" (_s can be "optimized later")
-- (used to bind variables in pattern matching)
| ICOut { iConType :: IType, conTagInfo :: ConTagInfo }
-- tuple constructor
-- fieldIds names fields of struct that turned into this tuple
| ICTuple { iConType :: IType, fieldIds :: [Id] }
-- select field selNo out of tuple that has numSel fields
| ICSel { iConType :: IType, selNo :: Integer, numSel :: Integer }
-- reference to a Verilog module; vMethTs has types of method arguments
| ICVerilog { iConType :: IType,
isUserImport :: Bool,
vInfo :: VModInfo,
vMethTs :: [[IType]] }
-- underscores of different varieties:
-- - user-inserted (IUDontCare)
-- - unreachable _ (IUNotUsed) (needed for some expression data structs)
-- - pattern matching failure (IUNoMatch)
| ICUndet { iConType :: IType, iuKind :: UndefKind, imVal :: Maybe (IExpr a) }
-- numeric integer literal
| ICInt { iConType :: IType, iVal :: IntLit }
-- numeric real literal
| ICReal { iConType :: IType, iReal :: Double }
-- string literal
| ICString { iConType :: IType, iStr :: String }
-- character literal
| ICChar { iConType :: IType, iChar :: Char }
-- IO handle
| ICHandle { iConType :: IType, iHandle :: Handle }
-- instantiated Verilog module
| ICStateVar { iConType :: IType, iVar :: IStateVar a }
-- interface method argument variable
-- only exists after expansion
-- note that the identifier for the port comes from the id of the surrounding ICon
| ICMethArg { iConType :: IType }
-- external module input (either as port or parameter)
-- Only exists after expansion.
-- Note that the identifier for the port/param comes from
-- the id of the surrounding ICon.
-- ICModPort is used for dynamic inputs (including clock and reset wires)
| ICModPort { iConType :: IType }
| ICModParam { iConType :: IType }
-- reference to a local def in a module
-- (similar to ICDef, which is a reference to a package def)
-- this is created in iExpand, so it only exists in IModule
-- and does not appear in IPackage
-- XXX consider renaming it to ICModDef?
| ICValue { iConType :: IType, iValDef :: IExpr a }
-- module arguments that are interfaces -- NO LONGER SUPPORTED
| ICIFace { iConType :: IType, ifcTyId :: Id, ifcIds :: [(Id, Integer, Bool)] }
-- a constructor containing rule pragmas, which is used in the
-- arguments to PrimRule.
-- only exists before expansion
| ICRuleAssert { iConType :: IType, iAsserts :: [RulePragma] }
-- a constructor containing scheduling pragmas, which is used
-- as an argument to PrimAddSchedPragmas (applied to rules).
-- only exists before expansion
| ICSchedPragmas { iConType :: IType, iPragmas :: [CSchedulePragma] }
| ICClock { iConType :: IType, iClock :: IClock a }
| ICReset { iConType :: IType, iReset :: IReset a } -- iReset has effective type itBit1
| ICInout { iConType :: IType, iInout :: IInout a }
-- uninit is used to give simpler error messages for completely uninitialized bit vectors / vectors
| ICLazyArray { iConType :: IType, iArray :: ILazyArray a, uninit :: Maybe (IExpr a, IExpr a)}
| ICName { iConType :: IType, iName :: Id }
| ICAttrib { iConType :: IType, iAttributes :: [(Position,PProp)] }
-- This was updated to support a list of positions,
-- though most uses are a single position
| ICPosition { iConType :: IType, iPosition :: [Position] }
| ICType { iConType :: IType, iType :: IType }
| ICPred { iConType :: IType, iPred :: Pred a }
deriving (Show, Generic.Data, Generic.Typeable)
ordC :: IConInfo a -> Int
-- XXX This definition would be nice, but it imposes a (Data a) context
--ordC x = Generic.constrIndex (Generic.toConstr x)
ordC (ICDef { }) = 0
ordC (ICPrim { }) = 1
ordC (ICForeign { }) = 2
ordC (ICCon { }) = 3
ordC (ICIs { }) = 4
ordC (ICOut { }) = 5
ordC (ICTuple { }) = 6
ordC (ICSel { }) = 7
ordC (ICVerilog { }) = 8
ordC (ICUndet { }) = 9
ordC (ICInt { }) = 10
ordC (ICReal { }) = 11
ordC (ICString { }) = 12
ordC (ICChar { }) = 13
ordC (ICHandle { }) = 14
ordC (ICStateVar { }) = 15
ordC (ICMethArg { }) = 16
ordC (ICModPort { }) = 17
ordC (ICModParam { }) = 18
ordC (ICValue { }) = 19
ordC (ICIFace { }) = 20
ordC (ICRuleAssert { }) = 21
ordC (ICSchedPragmas { }) = 22
ordC (ICClock { }) = 23
ordC (ICReset { }) = 24
ordC (ICInout { }) = 25
ordC (ICLazyArray { }) = 26
ordC (ICName { }) = 27
ordC (ICAttrib { }) = 28
ordC (ICPosition { }) = 29
ordC (ICType { }) = 30
ordC (ICPred { }) = 31
instance Eq (IConInfo a) where
x == y = cmpC x y == EQ
x /= y = cmpC x y /= EQ
instance Ord (IConInfo a) where
compare x y = cmpC x y
cmpC :: IConInfo a -> IConInfo a -> Ordering
cmpC c1 c2 =
case compare (ordC c1) (ordC c2) of
LT -> LT
GT -> GT
EQ ->
case c1 of
ICDef { } -> EQ
ICPrim { } -> EQ
ICForeign { } -> compare (fcallNo c1) (fcallNo c2)
-- XXX ICCon should check conNo and numCon instead of relying
-- on the identifier equality from ICon
ICCon { iConType = t1 } -> compare t1 (iConType c2)
ICIs { iConType = t1 } -> compare t1 (iConType c2)
ICOut { iConType = t1 } -> compare t1 (iConType c2)
ICTuple { iConType = t1 } -> compare t1 (iConType c2)
ICSel { iConType = t1 } -> compare t1 (iConType c2)
ICVerilog { iConType = t1, vInfo = s1 } ->
-- ignores method types and whether they are user imports or not
compare (t1, s1) (iConType c2, vInfo c2)
ICUndet { iConType = t1, imVal = mval1 } -> compare (t1, mval1) (iConType c2, imVal c2)
ICInt { iConType = t1, iVal = i1 } -> compare (t1, i1) (iConType c2, iVal c2)
ICReal { iConType = t1, iReal = r1 } -> compare (t1, r1) (iConType c2, iReal c2)
ICString { iConType = t1, iStr = s1 } -> compare (t1, s1) (iConType c2, iStr c2)
ICChar { iChar = chr1 } ->
-- the type should always be Char (should we compare anyway?)
compare chr1 (iChar c2)
ICHandle { } -> EQ
ICStateVar { iVar = n1 } -> compare n1 (iVar c2)
ICValue { } -> EQ
ICMethArg { } -> EQ
ICModPort { } -> EQ
ICModParam { } -> EQ
ICIFace { ifcTyId = ti1, ifcIds = is1 } -> compare (ti1, is1) (ifcTyId c2, ifcIds c2)
ICRuleAssert { iAsserts = asserts } -> compare asserts (iAsserts c2)
ICSchedPragmas { iPragmas = pragmas } -> compare pragmas (iPragmas c2)
-- the ICon Id is not sufficient for equality comparison for Clk/Rst
ICClock { iClock = clock1 } -> compare clock1 (iClock c2)
ICReset { iReset = reset1 } -> compare reset1 (iReset c2)
-- for Inout, the ICon Id is the correct Id
ICInout { } -> EQ
ICLazyArray { iArray = arr } -> compare (map ac_ptr (Array.elems arr))
(map ac_ptr (Array.elems (iArray c2)))
ICName { iName = n } -> compare n (iName c2)
ICAttrib { iAttributes = pps } ->
let pps_no_pos = map snd pps
pps2_no_pos = map snd (iAttributes c2)
in compare pps_no_pos pps2_no_pos
ICPosition { iPosition = p1 } -> compare p1 (iPosition c2)
ICType {iType = t1 } -> compare t1 (iType c2)
ICPred {iPred = p1 } -> compare p1 (iPred c2)
isIConInt, isIConReal, isIConParam :: IExpr a -> Bool
isIConInt (ICon _ (ICInt { })) = True
isIConInt _ = False
isIConReal (ICon _ (ICReal { })) = True
isIConReal _ = False
isIConParam (ICon _ (ICModParam { })) = True
isIConParam _ = False
-- ============================================================
-- value/type substitution, free value/type variables
eSubst :: Id -> IExpr a -> IExpr a -> IExpr a
eSubst v x e = hyper e' e'
where e' = sub e
sub ee@(ILam i t e)
| v == i = ee
| i `S.member` fvx =
let i' = cloneId (S.toList vs) i
e' = eSubst i (IVar i') e
in ILam i' t (sub e')
| otherwise = ILam i t (sub e)
-- sub ee@(IVar i) = if i == v then setPos (getIdPosition i) x else ee
sub ee@(IVar i) = if i == v then x else ee
sub (ILAM i k e) = ILAM i k (sub e)
sub (IAps f ts es) = IAps (sub f) ts (map sub es)
-- don't sub into ICUndet's optional variable because it doesn't get
-- populated until after evaluation
sub ee@(ICon _ _) = ee
sub ee@(IRefT _ _ _) = ee -- no free vars inside IRefT
fvx = fVars' x
vs = fvx `S.union` aVars' e
{-
setPos p (ICon i ci) = ICon (setIdPosition p i) ci
setPos p (IVar i) = IVar (setIdPosition p i)
-- setPos p (IAps e ts es) = IAps (setPos p e) ts es
setPos p e = e
-}
-- --------------------