{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module ASyntax( APackage(..), getAPackageFieldInfos, getAPackageClocks, getAPackageInputs, getAPackageParamsPortsAndInouts, apkgIsMCD, apkgExposesClkOrRst, AId, AMethodId, AType(..), ASize, ARule(..), AAssumption(..), ARuleId, APred, AIFace(..), AInput, AAbstractInput(..), AOutput, AClock(..), AReset(..), AInout(..), AClockDomain, mkOutputWire, mkIfcInoutN, AExpr(..), ADef(..), ASPackage(..), ASPSignalInfo(..), ASPMethodInfo(..), ASPCommentInfo(..), AStateOut, AVInst(..), getSpecialOutputs, getOutputClockWires, getOutputClockPorts, getOutputResetPorts, getIfcInoutPorts, ASchedule(..), AScheduler(..), AAction(..), ANoInlineFun(..), ARuleDescr, aTZero, aTBool, aSBool, aXSBool, aRuleName, aRulePred, aTNat, aTAction, aTClock, aTReset, aTInout, aTInout_, isStringType, isSizedString, isUnsizedString, dropSize, unifyStringTypes, getArrayElemType, getArraySize, aIfaceName, aIfaceNameString, aIfaceProps, aIfaceResSize, aIfaceResType, aIfaceResId, aIfaceArgs, aIfaceArgSize, aIfaceRules, aIfaceRulesImpl, aIfaceSchedNames, aIfacePred, aiface_vname, aiface_argnames_width, aIfaceMethods, aIfaceHasAction, aTrue, aFalse, isTrue, isFalse, aNoReset, cmpASInt, getSchedulerIds, dropScheduleIds, dropSchedulerIds, aNat, AForeignCall(..), AForeignBlock, PPrintExpand(..), pPrintExpandFlags, ppeString, ppeAPackage, mkMethId, mkMethStr, isMethId, MethodPart(..), getParams, getPorts, getClocks, getResets, getInouts, getInstArgs, defaultAId, binOp, mkCFCondWireInstId, PExpandContext, defContext, bContext, pContext ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) #endif import Data.List(nub, intersect, (\\), partition) -- import ListUtil(mapFst) -- import IntegerUtil(integerFormatPref) import Eval import PPrint import IntLit import Id import IdPrint import PreIds(idPrimAction, idClock, idReset, idInout, idInout_, idPreludeRead, idNoReset) import Prim import ErrorUtil(internalError) import Backend import Pragma import PreStrings(fsDollar, fsUnderscore, fsEnable) import FStringCompat -- import Position(noPosition) import Position import Data.Maybe import Util(itos, fromJustOrErr) import VModInfo import Wires import ProofObligation(ProofObligation, MsgFn) import Flags import qualified Data.Map as M import ISyntax(IType) import InstNodes(InstTree) -- packages converted from ISyntax data APackage = APackage { -- package name apkg_name :: AId, -- module wrapped around a non-inlined function apkg_is_wrapped :: Bool, -- whether module compilation was specific to the chosen backend apkg_backend :: Maybe Backend, -- size parameters (names in verilog) apkg_size_params :: [AId], -- package inputs (ports and parameters) -- in the order described by wireinfo -- (i.e. clock, reset, inouts, provided method arguments, -- module arg ports, module arg parameters) apkg_inputs :: [AAbstractInput], -- table of different clock domains apkg_clock_domains :: [AClockDomain], -- description of external wires (e.g. clock and reset) apkg_external_wires :: VWireInfo, -- table of port names to source types apkg_external_wire_types :: M.Map VName IType, -- table of resets apkg_reset_list :: [(ResetId, AReset)], -- state elements (Verilog instances) apkg_state_instances :: [AVInst], -- local defs, in dependency-sorted order? apkg_local_defs :: [ADef], -- rules, in unspecified order apkg_rules :: [ARule], -- relationships among rule names apkg_schedule_pragmas :: [ASchedulePragma], -- interface methods apkg_interface :: [AIFace], -- comments on submodule instantiations apkg_inst_comments :: [(Id, [String])], -- instantiation tree of rules and methods apkg_inst_tree :: InstTree, -- proof obligations which have not yet been discharged apkg_proof_obligations :: [(ProofObligation AExpr, MsgFn)] } deriving (Eq, Show) instance Hyper APackage where hyper x y = (x==x) `seq` y getAPackageFieldInfos :: APackage -> [VFieldInfo] getAPackageFieldInfos = map aif_fieldinfo . apkg_interface getAPackageClocks :: APackage -> [AClock] getAPackageClocks APackage { apkg_clock_domains = acds } = concatMap snd acds getAPackageInputs :: APackage -> [(AAbstractInput, VArgInfo)] getAPackageInputs apkg = let -- get the two fields inputs = apkg_inputs apkg arginfos = wArgs (apkg_external_wires apkg) -- check that they are the same length inputs_length = length (apkg_inputs apkg) arginfos_length = length arginfos args_with_info = zip inputs arginfos in if (inputs_length /= arginfos_length) then internalError ("getAPackageInputs: " ++ "length inputs != length arginfos: " ++ ppReadable (inputs, arginfos)) else args_with_info -- returns the input ports, separated into params, ports and inouts -- (note that this converts abstract inputs to port inputs) getAPackageParamsPortsAndInouts :: APackage -> ([AInput], [AInput], [AInput]) getAPackageParamsPortsAndInouts apkg = let args_with_info = getAPackageInputs apkg drop_info (xs, ys, zs) = (map fst xs, map fst ys, map fst zs) cvtToPorts (xs, ys, zs) = (concatMap absInputToPorts xs, concatMap absInputToPorts ys, concatMap absInputToPorts zs) (params, rest) = partition (isParam . snd) args_with_info (inouts,ports) = partition (isInout . snd) rest in cvtToPorts $ drop_info $ (params, ports, inouts) apkgIsMCD :: APackage -> Bool apkgIsMCD apkg = let domains = apkg_clock_domains apkg clocks = concatMap snd domains resets = apkg_reset_list apkg in (length domains /= 1) || (length clocks /= 1) || (length resets > 1) apkgExposesClkOrRst :: APackage -> Bool apkgExposesClkOrRst apkg = let isClkOrRst (AIClock {}) = True isClkOrRst (AIReset {}) = True isClkOrRst _ = False in any isClkOrRst (apkg_interface apkg) -- a scheduled package -- rules and interface methods have turned into logic connected to state instances data ASPackage = ASPackage { -- package name aspkg_name :: AId, -- module wrapped around a pure function with pragma no-inline aspkg_is_wrapped :: Bool, -- parameters (names in Verilog) -- (i.e. module args generated as params, size parameters) -- XXX there are no size parameters because we don't support -- XXX synthesis of size-polymorphic modules aspkg_parameters :: [AInput], -- package outputs (output clocks/resets, method results/RDY) aspkg_outputs :: [AOutput], -- package inputs (input clocks/resets, method args/EN, module args) -- (i.e. clock, reset, method arguments, module args as ports) aspkg_inputs :: [AInput], -- package inouts (module args and provided interface) aspkg_inouts :: [AInput], -- state elements (Verilog instances) aspkg_state_instances :: [AVInst], -- state element outputs (wires coming out of state elements) aspkg_state_outputs :: [AStateOut], -- defs (all sorts) aspkg_values :: [ADef], -- inout defs aspkg_inout_values :: [ADef], -- foreign function calls (grouped by clock domain) aspkg_foreign_calls :: [AForeignBlock], -- wire ports from inlined submodules (RWire and CReg) -- which shouldn't be unecessarily inlined away aspkg_inlined_ports :: [AId], -- info about which Ids are for what purpose aspkg_signal_info :: ASPSignalInfo, -- user comments to be included in the output RTL aspkg_comment_info :: ASPCommentInfo } deriving (Eq, Show) instance Hyper ASPackage where hyper x y = (x==x) `seq` y data ASPSignalInfo = ASPSignalInfo { -- input params, ports, clocks, and resets are all in one list -- (can use isParam etc to filter it out) aspsi_inputs :: [AId], -- the interface output clocks (and possibly empty list of gates) aspsi_output_clks :: [(AId,[AId])], aspsi_output_rsts :: [AId], aspsi_ifc_iots :: [AId], -- the ifc methods aspsi_methods :: [ASPMethodInfo], -- inline submodule info (RWire and CReg) -- XXX this somewhat duplicates the aspkg_inlined_ports field -- * instance name -- * module name as String -- * list of ports that became signals aspsi_inlined_ports :: [(AId, String, [AId])], -- rule scheduling signals -- relation from rule name to its CAN_FIRE and WILL_FIRE signals aspsi_rule_sched :: [(AId, [AId])], -- mux selectors -- ids of defs created in AState for the selectors to submod muxes aspsi_mux_selectors :: [AId], -- mux values -- ids of defs created in AState for the values to submod muxes aspsi_mux_values :: [AId], -- submodule enables -- ids of defs created in AState for the enables to submod methods aspsi_submod_enables :: [AId] } deriving (Eq, Show) instance PPrint ASPSignalInfo where pPrint d p aspsi = text "ASPSignalInfo = " <> braces (text "Inputs" <+> pPrint d p (aspsi_inputs aspsi) $+$ text "Output Clocks" <+> pPrint d p (aspsi_output_clks aspsi) $+$ text "Output Resets" <+> pPrint d p (aspsi_output_rsts aspsi) $+$ text "Inouts" <+> pPrint d p (aspsi_ifc_iots aspsi) $+$ text "Methods" <+> pPrint d p (aspsi_methods aspsi) -- $+$ text "Inlined Ports" <+> pPrint d p (aspsi_inlined_ports aspsi) ) -- relation from method name to -- type of method (value, action, actionvalue) as string -- ports for RDY, EN, val, args -- names of the associated rules (for methods with actions) data ASPMethodInfo = ASPMethodInfo { aspm_name :: AId, aspm_type :: String, aspm_mrdyid :: Maybe AId, aspm_menableid :: Maybe AId, aspm_mresultid :: Maybe AId, aspm_inputs :: [AId], aspm_assocrules :: [AId] } deriving (Eq, Show) instance PPrint ASPMethodInfo where pPrint d p aspmi = text "method:" <+> pPrint d p( aspm_name aspmi) <+> text (aspm_type aspmi) <> equals <> braces ( pPrint d 0 (aspm_mrdyid aspmi) <+> pPrint d 0 (aspm_menableid aspmi) <+> pPrint d 0 (aspm_mresultid aspmi) <+> pPrint d 0 (aspm_inputs aspmi) $+$ pPrint d 0 (aspm_assocrules aspmi) ) instance Hyper ASPSignalInfo where hyper x y = (x==x) `seq` y data ASPCommentInfo = ASPCommentInfo { -- comments on submodule instantiations aspci_submod_insts :: [(Id, [String])], -- comments on rules aspci_rules :: [(AId, [String])] -- comments on methods -- aspsi_methods :: ... } deriving (Eq, Show) instance Hyper ASPCommentInfo where hyper x y = (x==x) `seq` y -- parallel rule groups; total order on state -- (first rule in the list writes, present only if there are state conflicts) data ASchedule = ASchedule { asch_scheduler :: [AScheduler], -- list of ruleids is REVERSE ordering for execution asch_rev_exec_order :: [ARuleId] } deriving (Eq, Show) instance Hyper ASchedule where hyper x y = (x==x) `seq` y newtype AScheduler = -- esposito: (r,f) s.t. -- f is the list of conditions for which -- rule r should not fire when enabled -- f is expressed as a -- list of rules that conflict with the rule r. -- In the future, f should be a list of list of rules, -- where the sublists are a list of rules which when -- enabled should disable the firing of r. -- So [[a,b],[c],[d,e,f]] = !(ab) && !c && !(def) ASchedEsposito [(ARuleId, [ARuleId])] deriving (Eq, Show) getSchedulerIds :: AScheduler -> [ARuleId] getSchedulerIds (ASchedEsposito fs) = map fst fs dropScheduleIds :: [ARuleId] -> ASchedule -> ASchedule dropScheduleIds dropIds (ASchedule gs order) = (ASchedule gs' order') where order' = order \\ dropIds gs' = map (dropSchedulerIds dropIds) gs dropSchedulerIds :: [ARuleId] -> AScheduler -> AScheduler dropSchedulerIds dropIds sch = let result = dropSchedulerIds' dropIds sch in -- paranoia check if (not . null) (dropIds `intersect` getSchedulerIds result) then internalError("ASyntax.dropSchedulerIds " ++ ppReadable dropIds ++ "\n" ++ ppReadable sch) else result dropSchedulerIds' :: [ARuleId] -> AScheduler -> AScheduler dropSchedulerIds' dropIds (ASchedEsposito fs) = ASchedEsposito fs' where fs' = [(rid, rs') | (rid, rs) <- fs, not (rid `elem` dropIds), let rs' = rs \\ dropIds] type AId = Id type AMethodId = AId data AType = -- Bit k ATBit { atb_size :: ASize } -- sized or unsized string | ATString { ats_maybe_size :: Maybe ASize } -- Verilog real number | ATReal -- PrimArray | ATArray { atr_length :: ASize, atr_elem_type :: AType } -- abstract type, PrimAction, Interface, Clock, .. -- (can take size parameters as arguments) | ATAbstract { ata_id :: AId, ata_sizes :: [ASize] } deriving (Eq, Ord, Show) instance Hyper AType where hyper x y = (x==x) `seq` y instance HasPosition AType where getPosition (ATAbstract {ata_id = id}) = getPosition id getPosition _ = noPosition aTZero, aTBool, aTNat :: AType aTZero = ATBit 0 aTBool = ATBit 1 aTNat = ATBit 32 aTAction, aTClock, aTReset :: AType aTAction = ATAbstract idPrimAction [] aTClock = ATAbstract idClock [] aTReset = ATAbstract idReset [] aTInout, aTInout_ :: ASize -> AType aTInout n = ATAbstract idInout [n] aTInout_ n = ATAbstract idInout_ [n] -- Useful routines for working with ATString types isStringType :: AType -> Bool isStringType (ATString _) = True isStringType _ = False isUnsizedString :: AType -> Bool isUnsizedString (ATString Nothing) = True isUnsizedString _ = False isSizedString :: AType -> Bool isSizedString (ATString (Just n)) = True isSizedString _ = False dropSize :: AType -> AType dropSize (ATString (Just _)) = ATString Nothing dropSize x = x unifyStringTypes :: [AType] -> AType unifyStringTypes [] = internalError "unifyStringTypes given an empty list" unifyStringTypes (t:ts) | isUnsizedString t = t | otherwise = helper t ts where helper t [] = t helper t (t1:ts) | t /= t1 = dropSize t | otherwise = helper t ts type ASize = Integer getArrayElemType :: AType -> AType getArrayElemType (ATArray _ t) = t getArrayElemType t = internalError ("getArrayElemType: " ++ ppReadable t) getArraySize :: AType -> ASize getArraySize (ATArray sz _) = sz getArraySize t = internalError ("getArraySize: " ++ ppReadable t) -- ---------- -- module inputs -- This a module input (or inout) port at the hardware level. -- This is how module inputs are expressed post AState. -- It is also how method inputs are currently represented. -- (If we want to support method inputs which are synthesized to multiple -- ports, such as structs with a port for each field, then we would change -- then to be AAbstractInput.) type AInput = (AId, AType) -- These are abstract inputs (including inouts), which can map to one or more -- hardware ports. These are used in APackage for module arg inputs, prior to -- being converted to AInput in AState. data AAbstractInput = -- simple input using one port AAI_Port AInput | -- clock osc and maybe gate AAI_Clock AId (Maybe AId) | AAI_Reset AId | AAI_Inout AId Integer -- room to add other types here, like: -- AAI_Struct [(AId, AType)] -- ... deriving (Eq, Show) absInputToPorts :: AAbstractInput -> [AInput] absInputToPorts (AAI_Port p) = [p] absInputToPorts (AAI_Clock osc Nothing) = [(osc, aTBool)] absInputToPorts (AAI_Clock osc (Just gate)) = [(osc, aTBool), (gate, aTBool)] absInputToPorts (AAI_Reset r) = [(r,aTBool)] absInputToPorts (AAI_Inout r n) = [(r,ATAbstract {ata_id = idInout_, ata_sizes = [n]})] -- ---------- -- Verilog instance output: name and type type AStateOut = (AId, AType) -- module outputs (export list): types can be seen from module definition type AOutput = (AId, AType) data AVInst = AVInst { avi_vname :: AId, -- name of Verilog instance avi_type :: AType, -- type (like ATAbstract "Prelude.VReg") avi_user_import :: Bool, -- whether it is a foreign module -- This field records the types/sizes of method inputs and outputs. -- XXX This list corresponds to vFields in the VModInfo, but cannot be -- XXX stored there, because VModInfo is created before types are known. -- There is a triple for each method in vFields of VModInfo. -- The triple contains the types of each argument (in order) and maybe -- the types of the EN and return value. -- NOTE: These are the output language types (i.e. ATBit n) avi_meth_types :: [([AType], Maybe AType, Maybe AType)], -- This field maps source-language types to their corresponding ports avi_port_types :: M.Map VName IType, avi_vmi :: VModInfo, -- Verilog names, conflict info, etc. avi_iargs :: [AExpr], -- list of instantiation arguments -- The number of used copies of each method (up to the max multiplicity) -- To ensure correlation, it is a pair of the method id to its -- number of used copies. (The total multiplicity is in the VFieldInfo.) avi_iarray :: [(AId, Integer)] } deriving (Eq, Show) -- Return output clock and reset wires (including "outhigh" gate ports). -- Note even though all special wires (so far) have type ATBit 1, -- it is controllable here. -- Returns the state-element-output id, the ASyntax type, -- and the Verilog name of the output port to connect to. getSpecialOutputs :: AVInst -> [(AId, AType, VPort)] getSpecialOutputs avi = let extractClkPorts (_, osc_port, Nothing) = [osc_port] extractClkPorts (_, osc_port, Just gate_port) = [osc_port, gate_port] -- throw away the association with the clock/reset name clk_ports = concatMap extractClkPorts (getOutputClockPorts avi) rst_ports = map snd (getOutputResetPorts avi) iot_ports = map snd (getIfcInoutPorts avi) in -- nub because special wires (e.g. an oscillator) -- can theoretically be reused nub (clk_ports ++ rst_ports ++ iot_ports) -- Does not return clock gates ports which are "outhigh" getOutputClockWires :: AVInst -> [(AId, -- Clock Id AId, -- Osc Maybe AId)] -- Gate getOutputClockWires avi = let vmi = avi_vmi avi out_clocks = [id | (Clock id) <- vFields vmi] mkOscWire osc_name = mkOutputWireId (avi_vname avi) osc_name mkGateWire gate_name = mkOutputWireId (avi_vname avi) gate_name clock_wires clk_id = case (lookupOutputClockWires clk_id vmi) of (osc_name, Nothing) -> (clk_id, mkOscWire osc_name, Nothing) (osc_name, Just gate_name) -> (clk_id, mkOscWire osc_name, Just (mkGateWire gate_name)) in map clock_wires out_clocks getOutputClockPorts :: AVInst -> [(AId, -- Clock Id (AId, AType, VPort), -- Osc Maybe (AId, AType, VPort))] -- Gate getOutputClockPorts avi = let vmi = avi_vmi avi out_clocks = [id | (Clock id) <- vFields vmi] mkOscPort clk_name = (mkOutputWireId (avi_vname avi) clk_name, ATBit 1, (clk_name, [VPclock])) mkGatePort (clk_gate_name, portprops) = (mkOutputWireId (avi_vname avi) clk_gate_name, ATBit 1, (clk_gate_name, (VPclockgate:portprops))) clock_ports id = case (lookupOutputClockPorts id vmi) of (clk_name, Nothing) -> (id, mkOscPort clk_name, Nothing) (clk_name, Just clk_gate_vport) -> (id, mkOscPort clk_name, Just (mkGatePort clk_gate_vport)) in map clock_ports out_clocks getOutputResetPorts :: AVInst -> [(AId, (AId, AType, VPort))] getOutputResetPorts avi = let vmi = avi_vmi avi output_resets = [id | (Reset id) <- vFields vmi] mkResetPort rst_name = (mkOutputWireId (avi_vname avi) rst_name, ATBit 1, (rst_name, [VPreset])) reset_ports id = let rst_name = lookupOutputResetPort id vmi in (id, mkResetPort rst_name) in map reset_ports output_resets getIfcInoutPorts :: AVInst -> [(AId, (AId, AType, VPort))] getIfcInoutPorts avi = let vmi = avi_vmi avi res_types = map (\ (_,_,mr) -> mr) (avi_meth_types avi) ifc_inouts = [(id,vn,ty) | (Inout id vn _ _, mr) <- zip (vFields vmi) res_types, let ty = fromJustOrErr ("ASyntax.unknown inout " ++ ppReadable id) mr] mkInoutPort ty vname = (mkOutputWireId (avi_vname avi) vname, ty, (vname, [VPinout])) inout_ports (id,vn,ty) = (id, mkInoutPort ty vn) in map inout_ports ifc_inouts {- vNParam :: VModInfo -> Integer vNParam (VModInfo _ _ _ as _ _ _) = length [x | Param x <- as] -} getParams :: AVInst -> [AExpr] getParams avi = [e | (i, e) <- getInstArgs avi, isParam i] getPorts :: AVInst -> [AExpr] getPorts avi = [e | (i, e) <- getInstArgs avi, isPort i] getInstArgs :: AVInst -> [(VArgInfo, AExpr)] getInstArgs avi = zip (vArgs vi) es where vi = avi_vmi avi es = avi_iargs avi getClocks :: AVInst -> [AExpr] getClocks avi = [e | (i,e) <- getInstArgs avi, isClock i] getResets :: AVInst -> [AExpr] getResets avi = [e | (i,e) <- getInstArgs avi, isReset i] getInouts :: AVInst -> [AExpr] getInouts avi = [e | (i,e) <- getInstArgs avi, isInout i] -- local definition data ADef = ADef { adef_objid :: AId, adef_type :: AType, adef_expr :: AExpr, adef_props :: [DefProp] } deriving (Eq, Ord, Show) instance HasPosition ADef where getPosition adef = getPosition (adef_objid adef ) instance Hyper ADef where hyper x y = (x==x) `seq` y -- last id has original rule if this one comes from a split; Nothing otherwise -- it's only used as an optimization; it's safe to put Nothing there data ARule = ARule { arule_id :: ARuleId, -- rule name with a suffix arule_pragmas :: [RulePragma], -- rule pragmas, -- e.g., no-implicit-conditions arule_descr :: ARuleDescr, -- string that describes the rule arule_wprops :: WireProps, -- clock domain and reset information arule_pred :: APred, -- rule predicate (CAN_FIRE) arule_actions :: [AAction], -- rule body (actions) arule_assumps :: [AAssumption], -- assumptions that should hold after this rule executes arule_parent :: (Maybe ARuleId) -- if this rule came from a split, -- Just parent rule name } deriving (Eq, Show) type ARuleDescr = String type ARuleId = Id type APred = AExpr aRuleName :: ARule -> ARuleId aRuleName = arule_id aRulePred :: ARule -> AExpr aRulePred = arule_pred data AAssumption = AAssumption { assump_property :: AExpr, -- property we've assumed holds assump_actions :: [AAction] -- actions to take if the property does NOT hold -- cannot include method calls } deriving (Eq, Show) -- the APred is the implicit condition to the scheduler data AIFace = AIDef { aif_name :: AId, aif_inputs :: [AInput], aif_props :: WireProps, aif_pred :: APred, aif_value :: ADef, aif_fieldinfo :: VFieldInfo, -- value methods have their own assumptions -- because there is no rule to attach it to aif_assumps :: [AAssumption] } | AIAction { aif_inputs :: [AInput], aif_props :: WireProps, aif_pred :: APred, aif_name :: AId, aif_body :: [ARule], aif_fieldinfo :: VFieldInfo } | AIActionValue { aif_inputs :: [AInput], aif_props :: WireProps, aif_pred :: APred, aif_name :: AId, aif_body :: [ARule], aif_value :: ADef, aif_fieldinfo :: VFieldInfo } -- trivial aif_inputs, props, pred? | AIClock { aif_name :: AId, aif_clock :: AClock, aif_fieldinfo :: VFieldInfo } | AIReset { aif_name :: AId, aif_reset :: AReset, aif_fieldinfo :: VFieldInfo } | AIInout { aif_name :: AId, aif_inout :: AInout, aif_fieldinfo :: VFieldInfo } deriving (Eq, Show) aIfaceName :: AIFace -> AId aIfaceName (AIDef { aif_value = (ADef i _ _ _)}) = i -- XXX use aif_name aIfaceName (AIAction { aif_name = i}) = i aIfaceName (AIActionValue { aif_name = i}) = i aIfaceName (AIClock { aif_name = i}) = i aIfaceName (AIReset { aif_name = i}) = i aIfaceName (AIInout { aif_name = i}) = i aIfaceNameString :: AIFace -> String aIfaceNameString i = getIdString (aIfaceName i) aiface_vname :: AIFace -> String aiface_vname i = getIdString (vf_name (aif_fieldinfo i)) -- wire properties aIfaceProps :: AIFace -> WireProps aIfaceProps (AIDef { aif_props = p }) = p aIfaceProps (AIAction { aif_props = p }) = p aIfaceProps (AIActionValue { aif_props = p }) = p aIfaceProps _ = emptyWireProps -- result size aIfaceResSize :: AIFace -> Integer aIfaceResSize (AIAction { }) = 0 aIfaceResSize (AIDef {aif_value = (ADef _ (ATBit n) _ _) }) = n aIfaceResSize (AIActionValue {aif_value = (ADef _ (ATBit n) _ _) }) = n aIfaceResSize x = internalError ("aIfaceResSize: " ++ show x) aIfaceResType :: AIFace -> AType -- XXX should be ATAction? aIfaceResType (AIAction { }) = ATBit 0 aIfaceResType (AIDef { aif_value = (ADef _ t _ _)}) = t aIfaceResType (AIActionValue { aif_value = (ADef _ t _ _)}) = t -- should not need type of clock or reset aIfaceResType x = internalError ("aIfaceResType: " ++ show x) aIfaceResId :: AIFace -> [AId] aIfaceResId (AIDef {aif_value = (ADef i _ _ _) }) = [i] aIfaceResId (AIActionValue {aif_value = (ADef i _ _ _) }) = [i] aIfaceResId _ = [] aIfaceArgs :: AIFace -> [AInput] aIfaceArgs (AIClock {}) = [] aIfaceArgs (AIReset {}) = [] aIfaceArgs (AIInout {}) = [] aIfaceArgs f = aif_inputs f -- associate the internal and external names and width of AIFace args aiface_argnames_width :: AIFace -> [(AId, String, Integer)] aiface_argnames_width (AIClock {}) = [] aiface_argnames_width (AIReset {}) = [] aiface_argnames_width aif = zip3 (map fst (aif_inputs aif)) (map (getVNameString . fst) (vf_inputs (aif_fieldinfo aif))) (map aIfaceArgSize (aif_inputs aif)) aIfaceArgSize :: AInput -> Integer aIfaceArgSize (_, ATBit size) = size aIfaceArgSize x = internalError ("aIfaceArgSize: " ++ show x) aIfaceRules :: AIFace -> [ARule] aIfaceRules (AIAction { aif_body = rs}) = rs aIfaceRules (AIActionValue { aif_body = rs}) = rs aIfaceRules _ = [] aIfaceRulesImpl :: AIFace -> [(ADef, ARule)] aIfaceRulesImpl (AIAction { aif_name = i, aif_body = rs }) = map (addRdyToARule rdyId) rs where rdyId = mkRdyId i aIfaceRulesImpl (AIActionValue { aif_name = i, aif_body = rs }) = map (addRdyToARule rdyId) rs where rdyId = mkRdyId i aIfaceRulesImpl _ = [] addRdyToARule :: Id -> ARule -> (ADef, ARule) addRdyToARule rdyId r0@(ARule { arule_id = ri, arule_pred = e }) = (d, r) where di = mkRdyId (mkRdyId ri) d = ADef di aTBool (APrim di aTBool PrimBAnd [e, ASDef aTBool rdyId]) [] r = r0 { arule_pred = (ASDef aTBool di) } -- The names of value methods and action/actionvalue rules aIfaceSchedNames :: AIFace -> [ARuleId] aIfaceSchedNames (AIAction { aif_body = rs}) = map arule_id rs aIfaceSchedNames (AIActionValue { aif_body = rs}) = map arule_id rs aIfaceSchedNames (AIDef { aif_value = d }) = [adef_objid d] aIfaceSchedNames _ = [] aIfacePred :: AIFace -> APred aIfacePred ifc@(AIDef {}) = aif_pred ifc aIfacePred ifc@(AIAction {}) = aif_pred ifc aIfacePred ifc@(AIActionValue {}) = aif_pred ifc aIfacePred ifc@(AIClock {}) = internalError ("aIfacePred: unexpected clock: " ++ ppReadable ifc) aIfacePred ifc@(AIReset {}) = internalError ("aIfacePred: unexpected reset: " ++ ppReadable ifc) aIfacePred ifc@(AIInout {}) = internalError ("aIfacePred: unexpected inout: " ++ ppReadable ifc) aIfaceMethods :: [AIFace] -> [AIFace] aIfaceMethods is = let getMethod (AIClock {}) = Nothing getMethod (AIReset {}) = Nothing getMethod (AIInout {}) = Nothing getMethod i = Just i in mapMaybe getMethod is aIfaceHasAction :: AIFace -> Bool aIfaceHasAction (AIAction {}) = True aIfaceHasAction (AIActionValue {}) = True aIfaceHasAction _ = False -- note no types because they are implicitly action data AAction = ACall { -- state method call aact_objid :: AId, acall_methid :: AMethodId, aact_args :: [AExpr] -- first element of the list is the condition } | AFCall { aact_objid :: AId, -- foreign function call afcall_fun :: String, afcall_isC :: Bool, aact_args :: [AExpr], -- first element of the list is the condition -- is it an action inserted by BSC to check an assumption aact_assump :: Bool } -- action part of a foreign ActionValue function | ATaskAction { aact_objid :: AId, ataskact_fun :: String, ataskact_isC :: Bool, ataskact_cookie :: Integer, -- correlation cookie aact_args :: [AExpr], -- first element is the condition -- the temporary to set, spliced in later ataskact_temp :: (Maybe Id), -- include the return value type for easy reference, -- and to support foreign functions with ignored values ataskact_value_type :: AType, -- is it an action inserted by BSC to check an assumption aact_assump :: Bool } deriving (Eq, Ord, Show) instance Hyper AAction where hyper x y = (x==x) `seq` y data AClock = AClock { aclock_osc :: AExpr, -- must be of type ATBit 1 aclock_gate :: AExpr -- must be of type ATBit 1 } deriving(Eq, Ord, Show) -- the Ord instance has little meaning - it is used for Maps and the like -- the Eq instance should be accurate -- (same oscillator and gate ==> same clock) -- though it may not catch aliasing instance PPrint AClock where pPrint d p (AClock osc gate) = (text "{ osc: ") <+> (pPrint d p osc) <+> (text "gate: ") <+> (pPrint d p gate) <+> (text "}") mkOutputWireId :: AId -> VName -> AId mkOutputWireId var_id (VName wire_str) = let var_fstr = getIdFString (unQualId var_id) wire_fstr = mkFString wire_str in mkId noPosition (concatFString [var_fstr, fsDollar, wire_fstr]) mkOutputWire :: AId -> VName -> AExpr mkOutputWire var_id wire_name = ASPort (ATBit 1) (mkOutputWireId var_id wire_name) mkIfcInoutN :: Integer -> AId -> VName -> AExpr mkIfcInoutN n var_id wire_name = ASPort (aTInout_ n) (mkOutputWireId var_id wire_name) type AClockDomain = (ClockDomain, [AClock]) -- domain identifier and all the associated clocks newtype AReset = AReset { areset_wire :: AExpr -- must be of type ATBit 1 } deriving (Eq, Ord, Show) newtype AInout = AInout { ainout_wire :: AExpr } deriving (Eq, Ord, Show) instance PPrint AReset where pPrint d p (AReset { areset_wire = wire }) = (text "{ wire: ") <+> (pPrint d p wire) <+> (text "}") instance PPrint AInout where pPrint d p (AInout { ainout_wire = wire }) = (text "{ wire: ") <+> (pPrint d p wire) <+> (text "}") -- Every expression is annotated with its (result) type -- all types should be ae_type -- all ids should be ae_objid data AExpr = APrim { -- Verilog primitive (e.g., +) ae_objid :: AId, ae_type :: AType, aprim_prim :: PrimOp, ae_args :: [AExpr] } | AMethCall { ae_type :: AType, ae_objid :: AId, ameth_id :: AMethodId, ae_args :: [AExpr] -- external state method call } -- like AMethCall, but for the return value of actionvalue methods, -- where the return value no longer has to care about the arguments, -- because the action (AAction) will handle the muxing and arbitration -- of arguments and there is no multiplicity for actionvalue methods | AMethValue { ae_type :: AType, ae_objid :: AId, ameth_id :: AMethodId } -- calls a combinatorial function expressed via module instantiation -- XXX this can be created not only via "noinline" in BSV, -- XXX but also "foreign" in Classic syntax; consider renaming? | ANoInlineFunCall { ae_type :: AType, ae_objid :: AId, ae_fun :: ANoInlineFun, ae_args :: [AExpr] } -- foreign function / task call | AFunCall { ae_type :: AType, ae_objid :: AId, ae_funname :: String, ae_isC :: Bool, ae_args :: [AExpr] -- external function call } | ATaskValue { -- value returned by an ActionValue foreign task call ae_type :: AType, ae_objid :: AId, ae_funname :: String, ae_isC :: Bool, ae_cookie :: Integer -- "cookie" identifying the call for later fixup -- arguments, etc. handled by the action side of the call } | ASPort { -- module ports ae_type :: AType, ae_objid :: AId } | ASParam { -- module parameters ae_type :: AType, ae_objid :: AId } | ASDef { -- reference to local definition or input to module ae_type :: AType, ae_objid :: AId } | ASInt { -- constant ae_objid :: AId, ae_type :: AType, ae_ival :: IntLit } | ASReal { -- real-valued constant ae_objid :: AId, ae_type :: AType, ae_rval :: Double } | ASStr { -- string literal ae_objid :: AId, ae_type :: AType, ae_strval :: String } | ASAny { -- don't care expression ae_type :: AType, ae_val :: Maybe (AExpr) } | ASClock { -- abstract clock ae_type :: AType, -- (will vanish after AState) ae_clock :: AClock } | ASReset { -- abstract reset ae_type :: AType, -- (will vanish after AState), ae_expr :: AReset } | ASInout { -- abstract inout ae_type :: AType, -- (will vanish after AState), ae_expi :: AInout } {- -- instead of using ASPort, ASPackage should create these: | AWire { ae_type :: AType, ae_objid :: AId } -- reset access on a submodule | AMReset { ae_type :: AType, -- always ATBit 1 ae_objid :: AId, ae_rstid :: AId } -- oscillator access on a submodule | AMOsc { ae_type :: AType, -- always ATBit 1 ae_objid :: AId, ae_clkid :: AId } -} -- oscillator access on a submodule | AMGate { ae_type :: AType, -- always ATBit 1 ae_objid :: AId, ae_clkid :: AId } deriving (Ord, Show) instance Hyper AExpr where hyper x y = (x==x) `seq` y instance Eq AExpr where APrim _ t op aexprs == APrim _ t' op' aexprs' = (t == t') && (op == op') && (aexprs == aexprs') AMethCall t aid mid aexprs == AMethCall t' aid' mid' aexprs' = (t == t') && (mid == mid') && (aexprs == aexprs') && (aid == aid') AMethValue t aid mid == AMethValue t' aid' mid' = (t == t') && (mid == mid') && (aid == aid') ANoInlineFunCall t aid af aexprs == ANoInlineFunCall t' aid' af' aexprs' = (t == t') && (af == af') && (aexprs == aexprs') && (aid == aid') AFunCall t aid af isC aexprs == AFunCall t' aid' af' isC' aexprs' = (t == t') && (af == af') && (isC == isC') && (aexprs == aexprs') && (aid == aid') ATaskValue t aid af isC n == ATaskValue t' aid' af' isC' n' = (t == t') && (aid == aid') && (af == af') && (isC == isC') && (n == n') ASPort t aid == ASPort t' aid' = (t == t') && (aid == aid') ASParam t aid == ASParam t' aid' = (t == t') && (aid == aid') ASDef t aid == ASDef t' aid' = (t == t') && (aid == aid') ASInt _ t il == ASInt _ t' il' = (t == t') && (il == il') ASReal _ t r == ASReal _ t' r' = (t == t') && (r == r') ASStr _ t str == ASStr _ t' str' = (t == t') && (str == str') ASAny t me == ASAny t' me' = ((t, me) == (t', me')) ASClock t c == ASClock t' c' = c == c' -- t and t' should be aTClock ASReset t e == ASReset t' e' = e == e' -- t and t' should be aTReset ASInout t e == ASInout t' e' = e == e' -- t and t' should be aTInout AMGate t oid cid == AMGate t' oid' cid' = (t == t') && (oid == oid') && (cid == cid') aexpr == aexpr' = False instance HasPosition AExpr where getPosition APrim{ ae_objid = p } = getPosition p getPosition AMethCall{ ae_objid = p } = getPosition p getPosition AMethValue{ ae_objid = p } = getPosition p getPosition ANoInlineFunCall{ ae_objid = p } = getPosition p getPosition AFunCall{ ae_objid = p } = getPosition p getPosition ATaskValue{ ae_objid = p } = getPosition p getPosition ASPort{ ae_objid = p } = getPosition p getPosition ASParam{ ae_objid = p } = getPosition p getPosition ASDef{ ae_objid = p } = getPosition p getPosition ASInt{ ae_objid = p } = getPosition p getPosition ASReal {ae_objid = p } = getPosition p getPosition ASStr{ ae_objid = p } = getPosition p getPosition ASAny{} = noPosition -- Is there something better? getPosition ASClock{} = noPosition -- Is there something better? getPosition ASReset{} = noPosition -- Is there something better? getPosition ASInout{} = noPosition -- Is there something better? getPosition AMGate{ ae_objid = p } = getPosition p -- noinlined function data ANoInlineFun = ANoInlineFun -- function nam String -- numeric types [Integer] -- port list (inputs,outputs), each is port name and size -- XXX sizes all seem to be generated as 0. ([(String, Integer)], [(String, Integer)]) -- when an instance name is assigned to the call, it is stored here (Maybe String) deriving (Eq, Ord, Show) -- first element are the oscillators whose edges trigger evaluation -- second element is the block of function calls type AForeignBlock = ([AExpr], [AForeignCall]) -- type not required because it is implicitly Action data AForeignCall = AForeignCall { afc_name :: AId, afc_fun :: String, afc_args :: [AExpr], -- first element of the list is the condition -- (including the WILL_FIRE of the calling rule) afc_writes :: [AId], -- identifiers set by this foreign function call afc_resets :: [AExpr] -- reset wires connected to this foreign function call -- inouts not connected to foreign function calls at present } deriving (Eq, Show) aSBool :: Bool -> AExpr aSBool b = ASInt defaultAId aTBool (ilBin (if b then 1 else 0)) -- moved as utility procedures from Synthesize.hs -- XXX should they check the result type? isFalse :: AExpr -> Bool isFalse (ASInt _ _ (IntLit _ _ 0)) = True isFalse _ = False isTrue :: AExpr -> Bool isTrue (ASInt _ _ (IntLit _ _ 1)) = True isTrue _ = False -- make an AXExprS which is a boolean aXSBool :: Bool -> AExpr aXSBool b = aSBool b aNat :: Integer -> AExpr aNat i = ASInt defaultAId aTNat (ilDec i) aTrue :: AExpr aTrue = aSBool True aFalse :: AExpr aFalse = aSBool False aNoReset :: AExpr aNoReset = ASReset aTReset (AReset (APrim idNoReset (ATBit 1) PrimResetUnassertedVal [])) cmpASInt :: AExpr -> AExpr -> Ordering cmpASInt (ASInt _ _ (IntLit { ilValue = i })) (ASInt _ _ (IntLit { ilValue = i' })) = compare i i' cmpASInt x y = internalError("cmpASInt: " ++ show x ++ " == " ++ show y) -------- instance PPrint APackage where pPrint d _ apkg = (text "APackage" <+> ppId d (apkg_name apkg) <> if (apkg_is_wrapped apkg) then text " -- function" else empty) $+$ (case (apkg_backend apkg) of Nothing -> empty Just be -> text " -- backend:" <+> pPrint d 0 be) $+$ text "-- APackage parameters" $+$ pPrint d 0 (apkg_size_params apkg) $+$ text "-- APackage arguments" $+$ foldr (($+$) . pPrint d 0) empty (apkg_inputs apkg) $+$ text "-- APackage wire info" $+$ pPrint d 0 (apkg_external_wires apkg) $+$ text "-- APackage clock domains" $+$ pPrint d 0 (apkg_clock_domains apkg) $+$ text "-- APackage resets" $+$ pPrint d 0 (apkg_reset_list apkg) $+$ text "-- AP state elements" $+$ foldr (($+$) . pPrint d 0) empty (apkg_state_instances apkg) $+$ text "-- AP local definitions" $+$ foldr (($+$) . pPrint d 0) empty (apkg_local_defs apkg) $+$ text "-- AP rules" $+$ foldr (($+$) . pPrint d 0) empty (apkg_rules apkg) $+$ text "-- AP scheduling pragmas" $+$ pPrint d 0 (apkg_schedule_pragmas apkg) $+$ text "-- AP interface" $+$ foldr ($+$) empty [(text "-- AP apkg_interface def" <+> pPrint d 0 (apkg_name apkg)) $+$ pPrint d 0 i | i <- apkg_interface apkg] $+$ text "-- AP instance comments" $+$ foldr (($+$) . ppInstComment d) empty (apkg_inst_comments apkg) $+$ text "-- AP remaining proof obligations" $+$ pPrint d 0 (apkg_proof_obligations apkg) ppInstComment :: PDetail -> (Id, [String]) -> Doc ppInstComment d (i, cs) = pPrint d 0 i <> colon $+$ vsep (map text cs) ppV :: PDetail -> (AId, AType) -> Doc ppV d (i, t) = pPrint d 0 i <+> text "::" <+> pPrint d 0 t <> text ";" instance PPrint AAbstractInput where pPrint d p (AAI_Port v) = ppV d v pPrint d p (AAI_Clock osc Nothing) = text "clock {" <+> (text "osc =" <+> pPrint d 0 osc) <+> text "}" pPrint d p (AAI_Clock osc (Just gate)) = text "clock {" <+> (text "osc =" <+> pPrint d 0 osc <> text "," <+> text "gate =" <+> pPrint d 0 gate) <+> text "}" pPrint d p (AAI_Reset r) = text "reset {" <+> pPrint d 0 r <+> text "}" pPrint d p (AAI_Inout r n) = text "inout {" <+> pPrint d 0 r <> text"[" <> pPrint d 0 n <> text"]" <+> text "}" instance PPrint AVInst where pPrint d _ (AVInst i t ui mts pts vi es ns) = pPrint d 0 i <+> text "::" <+> pPrint d 0 t <+> text "=" <+> (ppVTI d (vi, es, ns) $+$ text "meth types=" <> pPrint d 0 mts $+$ text "port types=" <> pPrint d 0 pts) instance Hyper AVInst where hyper x y = (x==x) `seq` y ppVTI :: PDetail -> (VModInfo, [AExpr], [(AId, Integer)]) -> Doc ppVTI d (vi, es, ns) = sep [pPrint d 0 (vName vi), pPrint d 0 vi, pPrint d 0 es, pPrint d 0 ns] instance PPrint ASPackage where pPrint d p pack@(ASPackage mi fmod ps exps is ios ss sos ds iods fs ws ids cmap) = (text "ASPackage" <+> ppId d mi <> if fmod then text " -- function" else text "") $+$ text "-- ASPackage parameters" $+$ (text "" <+> sep (map (pPrint d 0) ps) <> text ";") $+$ text "-- ASPackage outputs" $+$ (text "" <+> sep (map (pPrint d 0) exps) <> text ";") $+$ text "-- ASPackage inputs" $+$ foldr (($+$) . ppV d) (text "") is $+$ text "-- ASPackage inouts" $+$ foldr (($+$) . ppV d) (text "") ios $+$ text "-- ASP state elements" $+$ foldr (($+$) . pPrint d 0) (text "") ss $+$ text "-- ASP state elements outputs" $+$ foldr (($+$) . ppV d) (text "") sos $+$ text "-- ASP inlined rwire ports" $+$ foldr (($+$) . pPrint d 0) (text "") ws $+$ text "-- ASP definitions" $+$ foldr (($+$) . pPrint d 0) (text "") ds $+$ text "-- ASP inout definitions" $+$ foldr (($+$) . pPrint d 0) (text "") iods $+$ text "-- ASP foreign function calls" $+$ foldr (($+$) . pPrint d 0) (text "") fs $+$ text "--ASP Signal Info" $+$ pPrint d 0 (aspkg_signal_info pack) instance PPrint ASchedule where pPrint d p (ASchedule groups order) = (text "parallel:" <+> pPrint d 0 groups) $+$ (text "order:" <+> pPrint d 0 (reverse order)) instance PPrint AScheduler where pPrint d p (ASchedEsposito fs) = let ppDep (r,cfs) = pPrint d 0 r <+> text "->" <+> pPrint d 0 cfs in text "esposito:" <+> text "[" <> sep (punctuate (text ",") (map ppDep fs)) <> text "]" instance PPrint ADef where pPrint d _ (ADef i t e props) = (pPrint d 0 i <+> text "::" <+> pPrint d 0 t <> text ";") $+$ (pPrint d 0 i <> text " =" <+> pPrint d 0 e <> text ";") $+$ (if (null $ getIdProps i) then empty else text "-- IdProp" <+> text (show i) ) $+$ (if (null props) then empty else text "-- Properties" <+> pPrint d 0 props) pPred :: PDetail -> Int -> APred -> Doc pPred d p pred = text "pred: " <+> pPrint d p pred -- XXX cleanup needed. instance PPrint AIFace where -- XXX print assumptions pPrint d p ai@(AIDef {} ) = (text "--AIDef" <+> pPrint d p (aif_name ai)) $+$ foldr (($+$) . ppV d) empty (aif_inputs ai) $+$ pPrint d 0 (aif_value ai) $+$ pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ pPrint d 0 (aif_fieldinfo ai) $+$ text "" pPrint d p ai@(AIAction {} ) = (text "--AIAction" <+> pPrint d p (aif_name ai)) $+$ foldr (($+$) . ppV d) empty (aif_inputs ai) $+$ pPrint d p (aif_body ai) $+$ pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ pPrint d 0 (aif_fieldinfo ai) $+$ text "" pPrint d p ai@(AIActionValue {}) = -- XXX this should be done better (text "--AIActionValue" <+> pPrint d p (aif_name ai)) $+$ foldr (($+$) . ppV d) empty (aif_inputs ai) $+$ pPrint d p (aif_value ai) $+$ pPrint d p (aif_body ai) $+$ pPred d p (aif_pred ai) $+$ pPrint d 0 (aif_props ai) $+$ pPrint d 0 (aif_fieldinfo ai) $+$ text "" pPrint d p (AIClock i c _) = pPrint d 0 c pPrint d p (AIReset i r _) = pPrint d 0 r pPrint d p (AIInout i r _) = pPrint d 0 r instance PPrint ARule where pPrint d@PDDebug _ (ARule s _ _ _ p as _ _) = (text "rule" <+> pPrint d 0 s) pPrint d _ (ARule s rps sd wp p as asmps _) = vcat (map (pPrint d 0) rps) $+$ (text "rule" <+> pPrint d 0 s <> text (" " ++ show sd) <> text ":") $+$ (text " when" <+> pPrint d 0 p) $+$ (text " ==>" <+> ppActions d as) $+$ pPrint d 0 asmps $+$ pPrint d 0 wp instance PPrint AAssumption where pPrint d p (AAssumption pred as) = text "assume " <+> pPrint d p pred <+> text "else " <+> pPrint d p as ppActions :: PDetail -> [AAction] -> Doc ppActions d as = text "{" <+> sep (map ppA as) <+> text "}" where ppA a = pPrint d 0 a <> text ";" -- AFCall/ATaskAction prints i instead of the string name -- to print the Bluespec function being called, not the foreign one instance PPrint AAction where pPrint d _ (ACall i m (c : es)) | isOne c = pPrint d 0 i <> text "." <> ppMethId d m <+> sep (map (pPrint d 1) es) pPrint d _ (ACall i m (c : es)) = sep [ text "if" <+> pPrint d 0 c <+> text "then", nest 2 (pPrint d 0 i <> text "." <> ppMethId d m <+> sep (map (pPrint d 1) es)) ] pPrint d _ (AFCall i _ _ (c : es) _) | isOne c = pPrint d 0 i <+> sep (map (pPrint d 1) es) pPrint d _ (AFCall i _ _ (c : es) _) = sep [ text "if" <+> pPrint d 0 c <+> text "then", nest 2 (pPrint d 0 i <+> sep (map (pPrint d 1) es)) ] pPrint d _ (ATaskAction i _ _ n (c : es) _ _ _) | isOne c = pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrint d 1) es) pPrint d _ (ATaskAction i _ _ n (c : es) _ _ _) = sep [ text "if" <+> pPrint d 0 c <+> text "then", nest 2 (pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrint d 1) es)) ] pPrint _ _ x = internalError ("PPrint AAction: " ++ show x) -- AForeignCall prints i instead of the string name -- to print the Bluespec function being called, not the foreign one instance PPrint AForeignCall where pPrint d _ (AForeignCall i _ (c : es) [] _) | isOne c = pPrint d 0 i <+> sep (map (pPrint d 1) es) pPrint d _ (AForeignCall i _ (c : es) [] resets) = sep [ pPrint d 0 resets, text "if" <+> pPrint d 0 c <+> text "then", nest 2 (pPrint d 0 i <+> sep (map (pPrint d 1) es)) ] pPrint d _ (AForeignCall i _ (c : es) ids _) | isOne c = sep (map (ppId d) ids) <+> text " <- " <+> pPrint d 0 i <+> sep (map (pPrint d 1) es) pPrint d _ (AForeignCall i _ (c : es) ids resets) = sep [ pPrint d 0 resets, text "if" <+> pPrint d 0 c <+> text "then", nest 2 (sep (map (ppId d) ids) <+> text " <- " <+> pPrint d 0 i <+> sep (map (pPrint d 1) es)) ] pPrint _ _ x = internalError ("pPrint AForeignCall: " ++ show x) instance Hyper AForeignCall where hyper x y = (x==x) `seq` y isOne :: AExpr -> Bool isOne (ASInt _ _ (IntLit _ _ 1)) = True isOne _ = False instance PPrint AExpr where -- pPrint d p (APrim aid _ o es@(_:_:_)) | binOp o = -- pparen (p>0) $ sepList (map (pPrint d 1) es) (text "" <+> pPrint d 1 o <> (text ("_" ++ (createPositionString (getIdPosition aid))))) pPrint d p (APrim _ _ o es@(_:_:_)) | binOp o = pparen (p>0) $ sepList (map (pPrint d 1) es) (text "" <+> pPrint d 1 o) pPrint d p (APrim _ _ PrimCase (e:dd:ces)) = (text "case" <+> pPrint d 0 e <+> text "of") $+$ foldr ($+$) (text "_ ->" <+> pPrint d 0 dd) (f ces) where f [] = [] f (x:y:xs) = (pPrint d 0 x <+> text "->" <+> pPrint d 0 y) : f xs f x = internalError ("pPrint AExpr Aprim binOp: " ++ show x) pPrint d p (APrim _ _ PrimPriMux es) = pparen (p>0) $ text "primux" <+> sep (f es) where f [] = [] f (x:y:xs) = pparen True (sep [pPrint d 0 x <> text ",", pPrint d 0 y]) : f xs f x = internalError ("pPrint AExpr Aprim PriMux 1: " ++ show x) pPrint d p (APrim _ _ PrimMux es) = pparen (p>0) $ text "mux" <+> sep (f es) where f [] = [] f (x:y:xs) = pparen True (sep [pPrint d 0 x <> text ",", pPrint d 0 y]) : f xs f x = internalError ("pPrint AExpr Aprim PriMux 2: " ++ show x) pPrint d p (APrim _ _ o es) = pparen (p>0) $ pPrint d 1 o <+> sep (map (pPrint d 1) es) pPrint d p (ANoInlineFunCall _ i _ es) = pparen (p>0) $ pPrint d 1 i <+> sep (map (pPrint d 1) es) pPrint d p (AFunCall _ i _ _ es) = pparen (p>0) $ pPrint d 1 i <+> sep (map (pPrint d 1) es) pPrint d p (ATaskValue _ i _ _ n) = pparen (p>0) $ pPrint d 1 i <> text ("#" ++ itos(n)) pPrint d p (AMethCall _ i m es) = pparen (p>0 && not (null es)) $ pPrint d 1 i <> sep (text "." <> ppMethId d m : map (pPrint d 1) es) pPrint d p (AMethValue _ i m) = pparen (p>0) $ pPrint d 1 i <> text "." <> ppMethId d m pPrint d p (ASPort _ i) = pPrint d p i pPrint d p (ASParam _ i) = pPrint d p i pPrint d p (ASDef _ i) = pPrint d p i pPrint d p (ASInt _ (ATBit sz) i) = text (showSizedVeriIntLit sz i) pPrint d p (ASInt _ _ i) = text (showVeriIntLit i) pPrint d p (ASReal _ _ r) = pPrint d p r pPrint d p (ASStr _ _ s) = text (show s) pPrint d p (ASAny t Nothing) = ppExprType d t $ text "_" pPrint d p (ASAny t (Just v)) = ppExprType d t $ text "_[" <> pPrint d maxPrec v <> text "]" pPrint d p (ASClock _ c) = text "clock" <+> pPrint d p c pPrint d p (ASReset _ r) = text "reset" <+> pPrint d p r pPrint d p (ASInout _ r) = text "inout" <+> pPrint d p r pPrint d p (AMGate _ o c) = pPrint d 1 o <> text "." <> pPrint d 1 c <> text ".gate" ppMethId :: PDetail -> Id -> Doc ppMethId d@PDReadable m = ppId d (unQualId m) ppMethId d m = ppId d m ppExprType :: PDetail -> AType -> Doc -> Doc ppExprType d t e = text "(" <> e <+> text "::" <+> pPrint d 0 t <> text ")" instance PPrint AType where pPrint d p (ATBit n) = text ("Bit " ++ itos n) pPrint d p (ATReal) = text ("Real ") pPrint d p (ATString Nothing) = text "String (unsized)" pPrint d p (ATString (Just n)) = text ("String (" ++ (itos n) ++ " chars)") pPrint d p (ATArray sz ty) = text "Array" <+> text (itos sz) <+> pPrint d 0 ty pPrint d p (ATAbstract i ns) = sep (text "ABSTRACT: " : pPrint d 0 i : map (pPrint d 0) ns) binOp :: PrimOp -> Bool binOp p = p `elem` [PrimAdd, PrimSub, PrimAnd, PrimOr, PrimXor, PrimMul, PrimQuot, PrimRem, PrimSL, PrimSRL, PrimSRA, PrimEQ, PrimEQ3, PrimULE, PrimULT, PrimSLE, PrimSLT, PrimBAnd, PrimBOr, PrimConcat ] -- PRETTY PRINTING WITH DEFINITION EXPANSION -- data PExpandDef = PExpandDef {defmap :: M.Map AId AExpr ,lookupLimit :: Int ,lookupLevel :: Int} data PExpandLiteral = Sized | Boolean | Index deriving (Eq) data PExpandContext = PExpandContext { useParen :: Bool -- if needed ,parentOp :: Maybe PrimOp ,literal :: PExpandLiteral } getP :: PExpandContext -> Int getP ec = if useParen ec then 1 else 0 -- No parens, show use sized literal defContext :: PExpandContext defContext = PExpandContext { useParen=False, parentOp=Nothing, literal=Sized} -- Boolean Context bContext :: PExpandContext bContext = PExpandContext { useParen=False, parentOp=Nothing, literal=Boolean} -- use parens pContext :: PExpandContext pContext = PExpandContext { useParen=True, parentOp=Nothing, literal=Sized} class (PPrint a) => PPrintExpand a where pPrintExpand :: PExpandDef -> PDetail -> PExpandContext -> a -> Doc pPrintExpandFlags :: (PPrintExpand a) => Flags -> [ADef] -> PDetail -> PExpandContext -> a -> Doc pPrintExpandFlags flags ds = let edef = PExpandDef {defmap = M.fromList [(id,expr) | (ADef id _ expr _) <- ds ] ,lookupLimit = expandATSlimit flags ,lookupLevel = 0 } in pPrintExpand edef ppeString :: (PPrintExpand a) => [ADef] -> PExpandContext -> a -> String ppeString ds ec = let edef = PExpandDef {defmap = M.fromList [(id,expr) | (ADef id _ expr _) <- ds ] ,lookupLimit = 30 ,lookupLevel = 0 } in init . pretty 60 60 . pPrintExpand edef PDReadable ec instance (PPrintExpand a) => PPrintExpand [a] where pPrintExpand _ d _ [] = text "[]" pPrintExpand m d _ xs = let (y:ys) = reverse (map (pPrintExpand m d defContext) xs) ys' = map (<> text ",") ys xs' = reverse (y:ys') in text "[" <> sep xs' <> text "]" ppeAPackage :: Int -> PDetail -> APackage -> Doc ppeAPackage lim d apkg@(APackage { apkg_local_defs = ds }) = let edef = PExpandDef { defmap = M.fromList [(id,expr) | (ADef id _ expr _) <- ds ] ,lookupLimit = lim ,lookupLevel = 0 } in (text "APackage" <+> ppId d (apkg_name apkg) <> if apkg_is_wrapped apkg then text " -- function" else text "") $+$ (case (apkg_backend apkg) of Nothing -> empty Just be -> text " -- backend:" <+> pPrint d 0 be) $+$ text "-- APackage parameters" $+$ pPrint d 0 (apkg_size_params apkg) $+$ text "-- APackage arguments" $+$ foldr (($+$) . pPrint d 0) empty (apkg_inputs apkg) $+$ text "-- APackage wire info" $+$ pPrint d 0 (apkg_external_wires apkg) $+$ text "-- APackage clock domains" $+$ pPrint d 0 (apkg_clock_domains apkg) $+$ text "-- APackage resets" $+$ pPrint d 0 (apkg_reset_list apkg) $+$ text "-- AP state elements" $+$ foldr (($+$) . ppeVI edef d) empty (apkg_state_instances apkg) $+$ -- text "-- AP local definitions" $+$ -- foldr ($+$) empty (map (pPrintExpand edef d 0) (apkg_local_defs apkg)) $+$ text "-- AP rules" $+$ foldr (($+$) . pPrintExpand edef d defContext) empty (apkg_rules apkg) $+$ text "-- AP scheduling pragmas" $+$ pPrint d 0 (apkg_schedule_pragmas apkg) $+$ text "-- AP interface" $+$ foldr ($+$) empty [(text "-- AP apkg_interface def" <+> pPrint d 0 (apkg_name apkg)) $+$ pPrintExpand edef d defContext i | i <- apkg_interface apkg] $+$ text "-- AP instance comments" $+$ foldr (($+$) . ppInstComment d) empty (apkg_inst_comments apkg) $+$ text "-- AP remaining proof obligations" $+$ pPrint d 0 (apkg_proof_obligations apkg) ppeVI :: PExpandDef -> PDetail -> AVInst -> Doc ppeVI m d (AVInst i t ui mts pts vi es ns) = pPrint d 0 i <+> text "::" <+> pPrint d 0 t <+> text "=" <+> (ppeVTI m d (vi, es, ns) $+$ text "meth types=" <> pPrint d 0 mts $+$ text "port types=" <> pPrint d 0 pts) ppeVTI :: PExpandDef -> PDetail -> (VModInfo, [AExpr], [(AId, Integer)]) -> Doc ppeVTI m d (vi, es, ns) = sep [pPrint d 0 (vName vi), pPrint d 0 vi, pPrintExpand m d defContext es, pPrint d 0 ns] instance PPrintExpand AIFace where -- XXX print assumptions pPrintExpand m d ec (AIDef id is wp g b _ _) = (text "--" <+> pPrint d (getP ec) g) $+$ foldr (($+$) . ppV d) (pPrint d (getP ec) b) is $+$ text "" pPrintExpand m d ec (AIAction is wp g _ rs _) = (text "--" <+> pPrint d (getP ec) g) $+$ foldr (($+$) . ppV d) (pPrintExpand m d ec rs) is $+$ text "" pPrintExpand m d ec (AIActionValue is wp g _ rs b _) = (text "--" <+> pPrint d (getP ec) g) $+$ foldr (($+$) . ppV d) (pPrintExpand m d ec rs) is $+$ foldr (($+$) . ppV d) (pPrint d (getP ec) b) is $+$ text "" pPrintExpand m d ec (AIClock i c _) = pPrint d (getP ec) c pPrintExpand m d ec (AIReset i r _) = pPrint d (getP ec) r pPrintExpand m d ec (AIInout i r _) = pPrint d (getP ec) r instance PPrintExpand ARule where -- XXX print assumptions pPrintExpand m d@PDDebug _ (ARule s _ _ _ p as _ _) = (text "rule" <+> pPrint d 0 s) pPrintExpand m d _ (ARule s rps sd wp p as _ _) = vcat (map (pPrint d 0) rps) $+$ (text "rule" <+> pPrint d 0 s <> text (" " ++ show sd) <> text ":") $+$ (text " when" <+> pPrintExpand m d bContext p) $+$ (text " ==>" <+> ppeActions m d as) ppeActions :: PExpandDef -> PDetail -> [AAction] -> Doc ppeActions m d as = text "{" <+> sep (map ppeA as) <+> text "}" where ppeA a = pPrintExpand m d defContext a <> text ";" instance PPrintExpand AAction where pPrintExpand m d _ (ACall i meth (c : es)) | isOne c = pPrint d 0 i <> text "." <> ppMethId d meth <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d _ (ACall i meth (c : es)) = sep [ text "if" <+> pPrintExpand m d bContext c <+> text "then", nest 2 (pPrint d 0 i <> text "." <> ppMethId d meth <+> sep (map (pPrintExpand m d pContext) es)) ] pPrintExpand m d _ (AFCall i _ _ (c : es) _) | isOne c = pPrint d 0 i <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d _ (AFCall i _ _ (c : es) _) = sep [ text "if" <+> pPrintExpand m d bContext c <+> text "then", nest 2 (pPrint d 0 i <+> sep (map (pPrintExpand m d pContext) es)) ] pPrintExpand m d _ (ATaskAction i _ _ n (c : es) _ _ _) | isOne c = pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d _ (ATaskAction i _ _ n (c : es) _ _ _) = sep [ text "if" <+> pPrintExpand m d defContext c <+> text "then", nest 2 (pPrint d 0 i <> text ("#" ++ itos(n)) <+> sep (map (pPrintExpand m d pContext) es)) ] pPrintExpand _ _ _ x = internalError ("pPrintExpand AAction: " ++ show x) isAssocOp :: PrimOp -> Bool isAssocOp PrimMul = True isAssocOp PrimAdd = True isAssocOp PrimOr = True isAssocOp PrimXor = True isAssocOp PrimBAnd = True isAssocOp PrimBOr = True isAssocOp _ = False instance PPrintExpand AExpr where pPrintExpand m d ec (APrim _ _ PrimConcat es) = bropt $ hsep ( punctuate comma docArgs ) where bropt = if (parentOp ec == Just PrimConcat) then id else braces ec' = defContext {parentOp = Just PrimConcat} docArgs = map (pPrintExpand m d ec') es pPrintExpand m d ec (APrim _ _ o es@(_:_:_)) | binOp o, isAssocOp o = pparen (p) $ sepList (map (pPrintExpand m d ec') es) (text "" <+> pPrint d 1 o) where ec' = ec {parentOp = Just o, useParen = True} p = (Just o /= parentOp ec) && useParen ec pPrintExpand m d ec (APrim _ _ o es@(_:_:_)) | binOp o = pparen (p) $ sepList (map (pPrintExpand m d ec') es) (text "" <+> pPrint d 1 o) where ec' = pContext {parentOp = Just o} p = useParen ec pPrintExpand m d ec (APrim _ _ PrimCase (e:dd:ces)) = (text "case" <+> pPrintExpand m d ec' e <+> text "of") $+$ foldr ($+$) (text "_ ->" <+> pPrintExpand m d ec' dd) (f ces) where ec' = defContext f [] = [] f (x:y:xs) = (pPrintExpand m d ec' x <+> text "->" <+> pPrintExpand m d ec' y) : f xs f x = internalError ("pPrintExpand APrim _ PrimCase: " ++ show x) pPrintExpand m d ec (APrim _ _ PrimPriMux es) = pparen (p) $ text "primux" <+> sep (f es) where p = useParen ec ec' = defContext { literal= literal ec} ecb = defContext { literal=Boolean } f [] = [] f (x:y:xs) = parens (sep [pPrintExpand m d ecb x <> comma, pPrintExpand m d ec' y]) : f xs f x = internalError ("pPrintExpand APrim _ PrimPriMux: " ++ show x) pPrintExpand m d ec (APrim _ _ PrimMux es) = pparen (p) $ text "mux" <+> sep (f es) where p = useParen ec ec' = defContext { literal= literal ec} ecb = defContext { literal=Boolean } f [] = [] f (x:y:xs) = parens (sep [pPrintExpand m d ecb x <> comma , pPrintExpand m d ec' y]) : f xs f x = internalError ("pPrintExpand APrim: " ++ show x) pPrintExpand m d ec (APrim _ _ PrimExtract [var, hi, lo]) = pPrintExpand m d pContext var <> lbrack <> (if ( dhi == dlo ) then dhi <> rbrack else dhi <> colon <> dlo <> rbrack ) where eci = defContext { literal= Index } dhi = pPrintExpand m d eci hi dlo = pPrintExpand m d eci lo pPrintExpand m d ec (APrim _ _ PrimIf [cond, thn, els]) = pparen(p) $ pPrintExpand m d ecc cond $$ text "?" <+> pPrintExpand m d ect thn $$ colon <+> pPrintExpand m d ece els where p = useParen ec ecc = pContext { literal = Boolean } ect = defContext {literal = literal ec} ece = pContext {literal = literal ec} pPrintExpand m d ec (APrim _ _ o es) = pparen (useParen ec) $ pPrint d 1 o <+> sep (map (pPrintExpand m d pContext) es) pPrintExpand m d ec (ANoInlineFunCall _ i _ es) = pPrint d 1 i <> ( parens $ sep $ punctuate comma (map (pPrintExpand m d defContext) es)) pPrintExpand m d ec (AFunCall _ i _ _ es) = pPrint d 1 i <> ( parens $ sep $ punctuate comma (map (pPrintExpand m d defContext) es)) pPrintExpand m d ec (ATaskValue _ i _ _ n) = pparen (useParen ec) $ pPrint d 1 i <> text ("#" ++ itos(n)) pPrintExpand m d ec (AMethCall _ i meth []) | qualEq meth idPreludeRead = pPrint d 1 i pPrintExpand m d ec (AMethCall _ i meth es) = pPrint d 1 i <> text "." <> ppMethId d meth <> if (null es) then empty else (parens (hsep ( punctuate comma docArgs )) ) where docArgs = map (pPrintExpand m d defContext) es pPrintExpand m d ec (AMethValue _ i meth) = pPrint d 1 i <> text "." <> ppMethId d meth pPrintExpand m d ec (ASPort _ i) = pPrint d (getP ec) i pPrintExpand m d ec (ASParam _ i) = pPrint d (getP ec) i pPrintExpand m d ec (ASDef _ i) | isIdWillFire i && (lookupLevel m) > 0 || isIdCanFire i && (lookupLevel m) > 1 = pPrint d (getP ec) i | (lookupLevel m) > (lookupLimit m) = pPrint d (getP ec) i <> text "(...)" | otherwise = let m' = m { lookupLevel = 1 + lookupLevel m } in pPrintExpand m' d ec $ defLookup i m pPrintExpand m d ec e@(ASInt _ (ATBit 1) i) | literal ec == Boolean, isFalse e = text "False" pPrintExpand m d ec e@(ASInt _ (ATBit 1) i) | literal ec == Boolean, isTrue e = text "True" pPrintExpand m d ec (ASInt _ (ATBit sz) i) | (literal ec == Index) = text (showVeriIntLit i) pPrintExpand m d ec (ASInt _ (ATBit sz) i) = text (showSizedVeriIntLit sz i) pPrintExpand m d ec (ASInt _ _ i) = text (showVeriIntLit i) pPrintExpand m d ec (ASReal _ _ r) = pPrint d (getP ec) r pPrintExpand m d ec (ASStr _ _ s) = text (show s) pPrintExpand m d ec (ASAny t _) = ppExprType d t $ text "_" pPrintExpand m d ec c@(ASClock { }) = pPrint d (getP ec) c pPrintExpand m d ec r@(ASReset { }) = pPrint d (getP ec) r pPrintExpand m d ec r@(ASInout { }) = pPrint d (getP ec) r pPrintExpand m d ec g@(AMGate { }) = pPrint d (getP ec) g defLookup :: AId -> PExpandDef -> AExpr defLookup d ped = M.findWithDefault err d (defmap ped) where err = internalError $ "defLookup: no definition `" ++ ppString d ++ "' found" -- ############################################################################# -- # Some standardized methods for making (default) method strings -- ############################################################################# data MethodPart = MethodArg Integer | -- argument 1, 2, ... input MethodResult | -- return value output MethodEnable -- enable signal input deriving (Eq) -- The method syntax is as follows: -- Arguments are $_ starting from 1 -- (e.g. the_fifo$enq_1) -- Return values are $ (e.g. the_fifo$first) -- Enable signals are $EN_ (e.g. the_fifo$EN_enq) -- Multi-ported methods are $__ -- The portnum is only omitted if the method has one or -- and infinite number of ports (like a register) mkMethId :: Id -> Id -> Maybe Integer -> MethodPart -> Id mkMethId o m ino mp = -- trace ("POS O: " ++ (show (getIdPosition o)) ++ " " ++ -- "POS M: " ++ (show (getIdPosition m))) $ addIdProps (mkId (getIdPosition o) idstring) (IdPMeth : (enprops ++ getIdProps o)) where idstring = (mkMethStr o m ino mp) enprops = if mp == MethodEnable then [IdP_enable] else [] isMethId :: Id -> Bool isMethId i = hasIdProp i IdPMeth mkMethStr :: Id -> Id -> Maybe Integer -> MethodPart -> FString mkMethStr obj m m_port mp = let meth_base = getIdFString (unQualId m) meth_port = case m_port of Nothing -> meth_base Just port -> concatFString [meth_base, fsUnderscore, mkNumFString port] base = case mp of MethodArg n -> if (n == 0) then internalError "mkMethStr" else concatFString [meth_port, fsUnderscore, mkNumFString n] MethodResult -> meth_port MethodEnable -> -- XXX are we overloading fsEnable? concatFString [fsEnable, meth_port] inst = getIdFString obj in concatFString [inst, fsDollar, base] -- ############################################################################# -- # -- ############################################################################# defaultAId :: Id defaultAId = mkId noPosition (mkFString "ABC") -- ############################################################################# -- # -- ############################################################################# -- name for the wire that tracks a method's calling condition -- _rule_EN_o$m mkCFCondWireInstId :: Id -> Id -> Id -> Id mkCFCondWireInstId object method rule = mkId pos str -- method part will be EN_o$m where methStr = mkMethStr object method Nothing MethodEnable (_, ruleStr) = getIdFStrings rule pos = getIdPosition rule str = concatFString [fsUnderscore, ruleStr, fsUnderscore, methStr]