{-# 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) import Backend import Prim(PrimOp(..)) import NumType 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 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 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 -} -- -------------------- etSubst :: Id -> IType -> IExpr a -> IExpr a etSubst v x e = sub e where sub (ILam i t e) = ILam i (tSubst v x t) (etSubst v x e) sub ee@(IVar i) = ee sub ee@(ILAM i k e) | v == i = ee | i `S.member` fvx = let i' = cloneId (S.toList vs) i e' = etSubst i (ITVar i') e in ILAM i' k (sub e') | otherwise = ILAM i k (sub e) sub (IAps f ts es) = IAps (sub f) (map (tSubst v x) ts) (map sub es) sub (ICon i ii@(ICUndet { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICVerilog { })) = ICon i (ICVerilog { iConType = tSubst v x (iConType ii), isUserImport = isUserImport ii, vMethTs = map (map (tSubst v x)) (vMethTs ii), vInfo = vInfo ii }) sub (ICon i ii@(ICInt { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICStateVar { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICMethArg { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICModPort { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICModParam { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICForeign { })) = ICon i (ii { iConType = tSubst v x (iConType ii) }) sub (ICon i ii@(ICType { })) = ICon i (ii { iType = tSubst v x (iType ii) }) sub ee@(ICon _ _) = ee sub ee@(IRefT _ _ _) = ee -- no free tyvar inside IRef fvx = fTVars' x vs = fvx `S.union` aVars' e -- -------------------- -- All variables -- aVars :: IExpr -> [Id] -- aVars e = S.toList (aVars' e) aVars' :: IExpr a -> S.Set Id aVars' (ILam i t e) = S.insert i (aVars' e `S.union` fTVars' t) aVars' (IVar i) = S.singleton i aVars' (ILAM i _ e) = S.insert i (aVars' e) aVars' (IAps f ts es) = (aVars' f) `S.union` (S.unions (map fTVars' ts)) `S.union` (S.unions (map aVars' es)) aVars' (ICon _ (ICUndet {imVal = Just e})) = aVars' e aVars' (ICon _ _) = S.empty -- XXX aVars' (IRefT _ _ _) = S.empty -- -------------------- -- Free variables fVars :: IExpr a -> [Id] fVars e = S.toList (fVars' e) fVars' :: IExpr a -> S.Set Id fVars' (ILam i _ e) = S.delete i (fVars' e) fVars' (IVar i) = S.singleton i fVars' (ILAM _ _ e) = fVars' e fVars' (IAps f ts es) = fVars' f `S.union` (S.unions (map fVars' es)) fVars' (ICon _ (ICUndet {imVal = Just e})) = fVars' e fVars' (ICon _ _) = S.empty fVars' (IRefT _ _ _) = S.empty -- -------------------- -- All definitions and variables fdVars :: IExpr a -> [Id] fdVars e = S.toList (fdVars' e) fdVars' :: IExpr a -> S.Set Id fdVars' (ILam i _ e) = fdVars' e fdVars' (IVar i) = S.singleton i fdVars' (ILAM _ _ e) = fdVars' e fdVars' (IAps f ts es) = fdVars' f `S.union` (S.unions (map fdVars' es)) fdVars' (ICon i (ICDef { })) = S.singleton i fdVars' (ICon i (ICValue { })) = S.singleton i fdVars' (ICon i (ICUndet {imVal = Just e})) = fdVars' e fdVars' (ICon _ _) = S.empty fdVars' (IRefT _ _ _) = S.empty -- -------------------- -- Free type variables ftVars :: IExpr a -> [Id] ftVars e = S.toList (ftVars' e) ftVars' :: IExpr a -> S.Set Id ftVars' (ILam i _ e) = ftVars' e ftVars' (IVar i) = S.empty ftVars' (ILAM i _ e) = S.delete i (ftVars' e) ftVars' (IAps f ts es) = (ftVars' f) `S.union` (S.unions (map fTVars' ts)) `S.union` (S.unions (map ftVars' es)) ftVars' (ICon _ (ICUndet {imVal = Just e})) = ftVars' e ftVars' (ICon _ _) = S.empty -- XXX ftVars' (IRefT _ _ _) = S.empty -- ============================================================ -- PPrint (for those instances not defined alongside the type, above) pPrintLink :: PDetail -> Int -> (Id, String) -> Doc pPrintLink d i (mi, hash) = (ppId d mi) <+> (text hash) instance PPrint (IPackage a) where pPrint d p (IPackage mi lps ps ds) = (text "IPackage" <+> ppId d mi) $+$ (text " --linked packages") $+$ foldr (($+$) . pPrintLink d 0) (text "") lps $+$ (text " --pragmas ") $+$ foldr (($+$) . pPrint d 0) (text "") ps $+$ (text " --idefs ") $+$ foldr (sep (text "next def..........................................................") . ppDef d) (text "") ds where sep a b c = b $+$ a $+$ c instance PPrint (IModule a) where pPrint d p (IModule mi fmod be wi ps ks as clks rsts vs pts ds rs ifc ffcalNo cmap) = (text "IModule" <+> ppId d mi <> if fmod then text " -- function" else text "") $+$ (case be of Nothing -> empty Just be -> text " -- backend specific:" <+> pPrint d 0 be) $+$ text "-- wire info" $+$ pPrint d p wi $+$ text "-- pragmas" $+$ foldr (($+$) . pPrint d 0) (text "") ps $+$ text "-- imod parameters" $+$ foldr (($+$) . ppMV d) (text "") ks $+$ text "-- imod args" $+$ foldr (($+$) . pPrint d 0) (text "") as $+$ text "-- imod clock domains" $+$ foldr (($+$) . pPrint d 0) (text "") clks $+$ foldr (($+$) . pPrint d 0) (text "") rsts $+$ text "-- imod state instances" $+$ foldr (($+$) . ppSV) (text "") vs $+$ text "-- port types" $+$ foldr (($+$) . ppPT) (text "") (M.toList pts) $+$ text "-- imod local defs" $+$ foldr (($+$) . ppDef d) (text "") ds $+$ text "-- imod rules" $+$ pPrint d 0 rs $+$ text "" $+$ text "-- imod interface" $+$ foldr (($+$) . pPrint d 0) (text "") ifc where ppSV (i, sv) = ppId d i <> pPrint d 0 sv ppPT (i, m) = foldr ($+$) (text "") [ ppPort i port <> text " :: " <> pPrint d 0 ty | (VName port, ty) <- M.toList m ] where ppPort Nothing p = text p ppPort (Just i) p = ppId d i <> text ("$" ++ p) ppMV :: (PPrint a) => PDetail -> (Id, a) -> Doc ppMV d (i, ty) = ppId d i <+> text "::" <+> pPrint d 0 ty instance PPrint (IEFace a) where pPrint d p (IEFace i vs et rules wp fi) = text "-- args" $+$ foldr (($+$) . ppMV d) b vs where b = text "-- body" $+$ (case et of Just (e,t) -> ppDef d $ IDef i t e [] _ -> empty ) $+$ text "-- rules" $+$ pPrint d 0 rules $+$ text "-- wire properties" $+$ pPrint d 0 wp $+$ text "-- field info" $+$ pPrint d 0 fi $+$ -- text "-- guard" $+$ -- ppDef d wi wt we $+$ text "" instance PPrint IAbstractInput where pPrint d p (IAI_Port (i,ty)) = ppId d i <+> text "::" <+> pPrint d 0 ty pPrint d p (IAI_Clock osc Nothing) = text "clock {" <+> (text "osc =" <+> pPrint d 0 osc) <+> text "}" pPrint d p (IAI_Clock osc (Just gate)) = text "clock {" <+> (text "osc =" <+> pPrint d 0 osc <> text "," <+> text "gate =" <+> pPrint d 0 gate) <+> text "}" pPrint d p (IAI_Reset r) = text "reset {" <+> pPrint d 0 r <+> text "}" pPrint d p (IAI_Inout r n) = text "inout {" <+> pPrint d 0 r <> text"[" <> pPrint d 0 n <> text"]" <+> text "}" instance PPrint (IStateVar a) where pPrint d p sv@(IStateVar _ _ _ vi xs t _ _ _ _) = let ps = [e | (i,e) <- zip (vArgs vi) xs, isParam i] as = [(v,e) | (Port (v,_) _ _, e) <- zip (vArgs vi) xs] ppPortConnection (VName s,e) = text ("." ++ s ++ "(") <> pPrint d 0 e <> text ")" in text " ::" <+> pPrint d 0 t <+> text "=" <+> pPrint d 0 (vName vi) <> (case ps of [] -> text "" _ -> text " #(" <> sepList (map (pPrint d 0) ps) (text ",") <> text ")") <> (case as of [] -> text "" _ -> text " (" <> sepList (map ppPortConnection as) (text ",") <> text ")") instance PPrint (IRule a) where pPrint d p (IRule { irule_name = longname, irule_pragmas = rps, irule_description = s, irule_pred = c, irule_body = a }) = (text "" <+> vcat (map (pPrint d 0) rps)) $+$ (text "" <+> text (show longname) <> text ":") $+$ (text "" <+> text (show s) <> text ":") $+$ (text " when" <+> pPrint d 0 c) $+$ (text " ==>" <+> pPrint d 0 a) instance PPrint (IRules a) where pPrint d p (IRules sps rs) = foldr (($+$) . pPrint d 0) (text "") sps $+$ foldr (($+$) . pPrint d 0) (text "") rs ppQuant :: PPrint a => String -> PDetail -> Int -> Id -> a -> IExpr b -> Doc ppQuant s d p i t e = pparen (p>0) (sep [text s <> pparen True (pPrint d 0 i <>text" ::" <+> pPrint d 0 t) <+> text ".", pPrint d 0 e]) --pparen (p>0) (text s <> pparen True (pPrint d 0 i <>text" ::" <+> pPrint d 0 t) <+> text "." <+> pPrint d 0 e) instance PPrint (IDef a) where pPrint d _p def = ppDef d def ppDef :: PDetail -> IDef a -> Doc ppDef d (IDef i t e p) = sep [pPrint d 0 i <+> text "::", nest 2 (pPrint d 0 t)] $+$ sep [pPrint d 0 i <+> text "=", nest 2 (pPrint d 0 e)] $+$ (if (null $ getIdProps i) then empty else text "-- IdProp:" <+> text (show i) ) $+$ (if (null p) then empty else text "-- Properties:" <+> text (show p -- avoid line wrap in what is supposed to be a comment )) instance PPrint (IExpr a) where pPrint d p (ILam i t e) = ppQuant "\\ " d p i t e pPrint d p e@(IAps (ICon _ (ICPrim { primOp = PrimJoinActions })) _ _) = let getActions (IAps (ICon _ (ICPrim { primOp = PrimJoinActions })) _ [e1, e2]) = getActions e1 ++ getActions e2 getActions e = [e] as = getActions e in text "{" <+> sepList (map (pPrint d 0) as) (text ";") <+> text "}" pPrint d p (IAps (ILam i t e') [] (e:es)) = pparen (p > 0) $ (text "let" <+> ppDef d (IDef i t e [])) $+$ (text "in " <> pPrint d 0 (iAps e' es)) pPrint d p (ICon i (ICUndet t _ Nothing)) = text "_ :: " <+> pPrint d maxPrec t pPrint d p (ICon i (ICUndet t _ (Just v))) = text "_[" <> pPrint d maxPrec v <> text "]" pPrint d@PDReadable p (ICon i (ICDef _ _)) = ppId d i <> text "=" pPrint d@PDReadable p (ICon i (ICVerilog { vInfo = vi })) = pparen True $ text "verilog" <+> pPrint d 0 vi pPrint d@PDReadable p (ICon i (ICIs _ _)) = ppId d i <> text "?" pPrint d@PDReadable p (ICon i (ICOut _ _)) = text "out" <> ppId d i pPrint d@PDReadable p (ICon i (ICSel _ _ _)) = text "." <> ppId d i pPrint d@PDReadable _ (ICon i (ICPrim _ p)) = text (show p) pPrint d@PDReadable _ (ICon i (ICIFace _ _ is)) = ppId d i <> text"{" <> sep (map (pPrint d 10) is) <> text "}" pPrint d@PDReadable _ (ICon i (ICLazyArray {})) = ppId d i <> text "[Array]" -- pPrint d@PDReadable _ (ICon id con) = ppId d id <> text (": " ++ show con) pPrint d p (IVar i) = ppId d i -- <> text ":V" pPrint d p (ILAM i k e) = ppQuant "/\\ " d p i k e pPrint d p (IAps f ts es) = pparen (p>(maxPrec-1)) $ sep (pPrint d (maxPrec-1) f : map (nest 2 . (text"\183" <>) . pPrint d maxPrec) ts ++ map (nest 2 . pPrint d maxPrec) es) pPrint d p (ICon _ (ICString t s)) = text (show s) pPrint d p (ICon _ (ICChar _ c)) = text (show c) pPrint d@PDDebug p (ICon _ (ICInt { iConType = t, iVal = i })) = pPrint d p i <> text "::" <> pPrint d maxPrec t pPrint d p (ICon _ (ICInt { iConType = t, iVal = i })) = pPrint d p i pPrint d p (ICon _ (ICReal { iConType = t, iReal = r })) = pPrint d p r pPrint d@PDDebug p (ICon i ict) = ppId d i <> text "::" <> pPrint d maxPrec (iConType ict) pPrint d p ict@(ICon i (ICForeign {fcallNo = (Just n)})) = ppId d i <> text ("#" ++ show n) pPrint d p (ICon i ict) = ppId d i pPrint d p (IRefT _ ptr _) = text ("_") <> pPrint d 0 ptr -- ============================================================ -- Hyper (for those instances not defined alongside the type, above) instance Hyper (IPackage a) where hyper (IPackage i lps ps ds) y = hyper4 i ps lps ds y instance Hyper (IModule a) where hyper (IModule x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16) y = hyper16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 y instance Hyper (IEFace a) where hyper (IEFace x1 x2 x3 x4 x5 x6) y = hyper6 x1 x2 x3 x4 x5 x6 y instance Hyper IAbstractInput where hyper (IAI_Port p) y = hyper p y hyper (IAI_Clock o mg) y = hyper2 o mg y hyper (IAI_Reset r) y = hyper r y hyper (IAI_Inout r n) y = hyper2 r n y instance Hyper (IDef a) where hyper (IDef i t e p) y = hyper4 i t e p y instance Hyper (IExpr a) where hyper (ILam i t e) y = hyper3 i t e y hyper (IAps e ts es) y = hyper3 e ts es y hyper (IVar i) y = hyper i y hyper (ILAM i k e) y = hyper3 i k e y hyper (ICon i ic) y = hyper2 i ic y hyper (IRefT t p _) y = hyper t y instance Hyper (IConInfo a) where -- hyper (ICDef x1 x2) y = hyper2 x1 x2 y hyper ic@(ICDef x1 x2) y = y -- XXX a hack to avoid circular defs hyper (ICPrim x1 x2) y = hyper2 x1 x2 y hyper (ICForeign x1 x2 x3 x4 x5) y = hyper5 x1 x2 x3 x4 x5 y hyper (ICCon x1 x2) y = hyper2 x1 x2 y hyper (ICIs x1 x2) y = hyper2 x1 x2 y hyper (ICOut x1 x2) y = hyper2 x1 x2 y hyper (ICTuple x1 x2) y = hyper2 x1 x2 y hyper (ICSel x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICVerilog x1 x2 x3 x4) y = hyper4 x1 x2 x3 x4 y hyper (ICUndet x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICInt x1 x2) y = hyper2 x1 x2 y hyper (ICReal x1 x2) y = hyper2 x1 x2 y hyper (ICString x1 x2) y = hyper2 x1 x2 y hyper (ICChar x1 x2) y = hyper2 x1 x2 y hyper (ICHandle x1 x2) y = hyper2 x1 x2 y hyper (ICStateVar x1 x2) y = hyper2 x1 x2 y hyper (ICMethArg x1) y = hyper x1 y hyper (ICModPort x1) y = hyper x1 y hyper (ICModParam x1) y = hyper x1 y -- hyper (ICValue x1 x2 x3) y = hyper3 x1 x2 x3 y -- XXX causes cycles somehow hyper (ICValue x1 x2) y = y hyper (ICIFace x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICRuleAssert x1 x2) y = hyper2 x1 x2 y hyper (ICSchedPragmas x1 x2) y = hyper2 x1 x2 y hyper (ICClock x1 x2) y = hyper2 x1 x2 y hyper (ICReset x1 x2) y = hyper2 x1 x2 y hyper (ICInout x1 x2) y = hyper2 x1 x2 y hyper (ICName x1 x2) y = hyper2 x1 x2 y hyper (ICAttrib x1 x2) y = hyper2 x1 x2 y hyper (ICLazyArray x1 x2 x3) y = hyper3 x1 x2 x3 y hyper (ICPosition x1 x2) y = hyper2 x1 x2 y hyper (ICType x1 x2) y = hyper2 x1 x2 y hyper (ICPred x1 x2) y = hyper2 x1 x2 y instance Hyper (IStateVar a) where hyper x y = (x==x) `seq` y -- XXX (does not evaluate IStateVar components) -- ============================================================ -- XRef (and other utilities?) beyond this point -- ############################################################################# -- # -- ############################################################################# getIExprPositionCross :: IExpr a -> Position getIExprPositionCross iexpr = if (True) then (getIExprPositionCrossInternal 0 iexpr) else noPosition -- getITypePositionCross :: IType -> Position -- getITypePositionCross itype = -- if (True) -- then (getITypePositionCrossInternal 0 itype) -- else noPosition -- ############################################################################# -- # -- ############################################################################# getIExprPositionCrossInternal :: Int -> IExpr a -> Position getIExprPositionCrossInternal 10 _ = noPosition getIExprPositionCrossInternal n (ILam i _ e) = let pos = (getIExprPositionCrossInternal (n + 1) e) in firstPos [pos, getIdPosition i] getIExprPositionCrossInternal n (IAps e ts es) = let pos = (getIExprPositionCrossInternal (n + 1) e) in firstPos (pos : (map (getIExprPositionCrossInternal (n + 1)) es)) getIExprPositionCrossInternal _ (IVar i) = getIdPosition i getIExprPositionCrossInternal n (ILAM i _ e) = let pos = (getIExprPositionCrossInternal (n + 1) e) in firstPos [pos, getIdPosition i] -- getIExprPositionCrossInternal n (ICon i (ICPrim t op)) = -- getITypePositionCrossInternal (n + 1) t getIExprPositionCrossInternal _ (ICon i (ICSel _ _ _)) = if (isPassThroughOp i) then -- trace("DDD " ++ (pfpString i)) $ noPosition else -- trace("CCC " ++ (pfpString i)) $ (getIdPosition i) getIExprPositionCrossInternal _ (ICon i _) = getIdPosition i getIExprPositionCrossInternal n (IRefT t _ _) = getITypePositionCrossInternal (n + 1) t getITypePositionCrossInternal :: Int -> IType -> Position getITypePositionCrossInternal 10 _ = noPosition getITypePositionCrossInternal n (ITForAll i _ t) = let pos = (getIdPosition i) in firstPos [pos, (getITypePositionCrossInternal (n + 1) t)] getITypePositionCrossInternal n (ITAp t t') = let t_pos = getITypePositionCrossInternal (n + 1) t t'_pos = getITypePositionCrossInternal (n + 1) t' pos_list = [t_pos, t'_pos] in firstPos pos_list getITypePositionCrossInternal _ (ITVar i) = getIdPosition i getITypePositionCrossInternal _ (ITCon i _ _) = getIdPosition i getITypePositionCrossInternal _ (ITNum _) = noPosition getITypePositionCrossInternal _ (ITStr _) = noPosition -- ############################################################################# -- # A bunch of operators we don't want messing with "real" position info. -- ############################################################################# idMonadNoPos, idBindNoPos, idFromIntegerNoPos, idReturnNoPos :: Id idMonadNoPos = idMonad noPosition idBindNoPos = idBind noPosition idFromIntegerNoPos = idFromInteger noPosition idReturnNoPos = idReturn noPosition isPassThroughOp :: Id -> Bool isPassThroughOp i = (i == idBit) || (i == idMonadNoPos) || (i == idBindNoPos) || (i == idFromIntegerNoPos) || (i == idLiftModule) || (i == idPack) || (i == idReturnNoPos) || (i == idUnpack) -- ############################################################################# -- # -- ############################################################################# getIExprPosition :: IExpr a -> Position getIExprPosition (ILam i t e) = let t_pos = getITypePosition t i_pos = getIExprPosition e pos_list = [getIdPosition i, t_pos, i_pos] in firstPos pos_list getIExprPosition (IAps e ts es) = let t_pos_list = map getITypePosition ts i_pos_list = map getIExprPosition es pos_list = getIExprPosition e : t_pos_list ++ i_pos_list in firstPos pos_list getIExprPosition (IVar i) = getIdPosition i getIExprPosition (ILAM i _ e) = firstPos [getIdPosition i, getIExprPosition e] -- getIExprPosition (ICon i (ICPrim t op)) = getITypePosition t getIExprPosition (ICon i _) = getIdPosition i getIExprPosition (IRefT t _ _) = getITypePosition t getITypePosition :: IType -> Position getITypePosition (ITForAll i _ t) = firstPos [getIdPosition i, getITypePosition t] getITypePosition (ITAp t t') = let t_pos = getITypePosition t t'_pos = getITypePosition t' pos_list = [t_pos, t'_pos] in firstPos pos_list getITypePosition (ITVar i) = getIdPosition i getITypePosition (ITCon i _ _) = getIdPosition i getITypePosition (ITNum _) = noPosition getITypePosition (ITStr _) = noPosition -------- iAP :: IExpr a -> IType -> IExpr a iAP (IAps f ts []) t = IAps f (ts ++ [t]) [] iAP f t = IAps f [t] [] iAp :: IExpr a -> IExpr a -> IExpr a iAp (IAps f ts es) e = IAps f ts (es ++ [e]) iAp f e = IAps f [] [e] iAps :: IExpr a -> [IExpr a] -> IExpr a iAps f [] = f iAps f es = IAps f [] es mkNumConT :: Integer -> IType mkNumConT i = if i < 0 then internalError ("mkNumCon: " ++ show i) else ITNum i -------- -- shallow printing that avoids looping showTypeless :: IExpr a -> String showTypeless (ILam i _ e) = "(ILam " ++ (show i) ++ " _ " ++ (showTypeless e) ++ ")" showTypeless (IAps e _ es) = "(IAps " ++ (showTypeless e) ++ " _ " ++ showTypelessList es ++ ")" showTypeless (IVar i) = "(IVar " ++ (show i) ++ ")" showTypeless (ILAM i k e) = "(ILAM " ++ (show i) ++ " " ++ (show k) ++ " " ++ (showTypeless e) ++ ")" showTypeless (ICon i ci) = "(ICon " ++ (show i) ++ " " ++ (showTypelessCI ci) ++ " )" showTypeless (IRefT _ i _) = "(IRefT " ++ "_" ++ (show i) ++ ")" showTypelessRule :: IRule a -> String showTypelessRule (IRule { irule_name = n, irule_pragmas = rps, irule_description = s, irule_pred = c, irule_body = a }) = "(IRule " ++ (show n) ++ "\n\t" ++ (show rps) ++ "\n\t" ++ (show s) ++ "\n\t" ++ (showTypeless c) ++ "\n\t" ++ (showTypeless a) ++ "\n)" showTypelessRules :: IRules a -> String showTypelessRules (IRules sps rs) = "(IRules " ++ show sps ++ " [" ++ foldr1 (\x y -> x ++ ", " ++ y) (map showTypelessRule rs) ++ "])" showTypelessCI :: IConInfo a -> String showTypelessCI (ICDef {iConType = t, iConDef = e}) = "(ICDef)" showTypelessCI (ICPrim {iConType = t, primOp = p}) = "(ICPrim _ " ++ (show p) ++ ")" showTypelessCI (ICForeign {iConType = t, fName = n, isC = b, foports = f}) = "(ICForeign _ " ++ n ++ " " ++ show b ++ " " ++ (show f) ++ ")" showTypelessCI (ICCon {iConType = t, conTagInfo = cti}) = "(ICCon _ " ++ (ppReadable cti) ++ ")" showTypelessCI (ICIs {iConType = t, conTagInfo = cti}) = "(ICIs _ " ++ (ppReadable cti) ++ ")" showTypelessCI (ICOut {iConType = t, conTagInfo = cti}) = "(ICOut _ " ++ (ppReadable cti) ++ ")" showTypelessCI (ICTuple {iConType = t, fieldIds = fs}) = "(ICTuple _ " ++ (show fs) ++ ")" showTypelessCI (ICSel {iConType = t, selNo = i, numSel = j}) = "(ICSel _ " ++ (show i) ++ " " ++ (show j) ++ ")" showTypelessCI (ICVerilog {iConType = t, isUserImport = ui, vInfo = v, vMethTs = vts}) = "(ICVerilog _ " ++ {--(show v)--} "" ++ " [_])" showTypelessCI (ICUndet {iConType = t, iuKind = k, imVal = Nothing}) = "(ICUndet _ _ )" showTypelessCI (ICUndet {iConType = t, iuKind = k, imVal = Just v}) = "(ICUndet _ _ [" ++ ppReadable v ++ "])" showTypelessCI (ICInt {iConType = t, iVal = v}) = "(ICInt _ " ++ (show v) ++ ")" showTypelessCI (ICReal {iConType = t, iReal = v}) = "(ICReal _ " ++ (show v) ++ ")" showTypelessCI (ICString {iConType = t, iStr = s}) = "(ICString _ " ++ (show s) ++ ")" showTypelessCI (ICChar {iConType = t, iChar = c}) = "(ICChar _ " ++ (show c) ++ ")" showTypelessCI (ICHandle {iConType = t, iHandle = h}) = "(ICHandle _ " ++ (show h) ++ ")" showTypelessCI (ICStateVar {iConType = t, iVar = v}) = "(ICStateVar _ " ++ (showTypelessStateVar v) ++ ")" showTypelessCI (ICMethArg {iConType = t}) = "(ICMethArg _ )" showTypelessCI (ICModPort {iConType = t}) = "(ICModPort _ )" showTypelessCI (ICModParam {iConType = t}) = "(ICModParam _ )" showTypelessCI (ICValue {iConType = t, iValDef = e}) = "(ICValue)" showTypelessCI (ICIFace {iConType = t, ifcTyId = i, ifcIds = ids}) = "(ICIFace _ " ++ (show i) ++ " " ++ (show ids) ++ ")" showTypelessCI (ICRuleAssert {iConType = t, iAsserts = rps}) = "(ICRuleAssert _ " ++ (show rps) ++ ")" showTypelessCI (ICSchedPragmas {iConType = t, iPragmas = sps}) = "(ICSchedPragmas _ " ++ (show sps) ++ ")" showTypelessCI (ICClock {iConType = t, iClock = clock}) = "(ICClock)" showTypelessCI (ICReset {iConType = t, iReset = reset}) = "(ICReset)" showTypelessCI (ICInout {iConType = t, iInout = inout}) = "(ICInout)" showTypelessCI (ICName {iConType = t, iName = name}) = "(ICName _ " ++ (show name) ++ ")" showTypelessCI (ICAttrib {iConType = t, iAttributes = pps}) = "(ICAttrib _ " ++ (show (map snd pps)) ++ ")" showTypelessCI (ICLazyArray {iConType = t, iArray = arr}) = "(ICLazyArray _ " ++ (ppReadable (map ac_ptr (Array.elems arr))) ++ ")" showTypelessCI (ICPosition {iConType = t, iPosition = pos}) = "(ICPosition _ " ++ (show pos) ++ ")" showTypelessCI (ICType {iType = t}) = "(ICType _ " ++ (show t) ++ ")" showTypelessCI (ICPred {iPred = p}) = "(ICPred _ " ++ (show p) ++ ")" showTypelessStateVar :: IStateVar a -> String showTypelessStateVar (IStateVar b ui i v es ts mts ncs nrs l) = "(IStateVar " ++ (show b) ++ " " ++ (show i) ++ " " ++ " " {-- showTypelessList es --} ++ "_" ++ " [[_]] " ++ "" ++ ")" showTypelessList :: [IExpr a] -> String showTypelessList es = "[" ++ intercalate ", " (map showTypeless es) ++ "]" -- ############################################################################# -- # -- #############################################################################