1 module FlattenTypes where
4 import Data.Traversable
5 import qualified Data.Foldable as Foldable
6 import qualified Control.Monad.State as State
13 -- | A signal identifier
16 -- | A map of a Haskell value to signal ids
17 type SignalMap = HsValueMap SignalId
19 -- | A state identifier
22 -- | How is a given (single) value in a function's type (ie, argument or
23 -- return value) used?
25 Port -- ^ Use it as a port (input or output)
26 | State StateId -- ^ Use it as state (input or output). The int is used to
27 -- match input state to output state.
28 | HighOrder { -- ^ Use it as a high order function input
29 hoName :: String, -- ^ Which function is passed in?
30 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
31 -- ^ map should only contain Port and other
34 deriving (Show, Eq, Ord)
36 -- | Is this HsValueUse a state use?
37 isStateUse :: HsValueUse -> Bool
38 isStateUse (State _) = True
41 -- | A map from a Haskell value to the use of each single value
42 type HsUseMap = HsValueMap HsValueUse
44 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
45 -- which all the Single elements are marked as State, with increasing state
47 useAsState :: HsValueMap a -> HsUseMap
51 -- Traverse the existing map, resulting in a function that maps an initial
52 -- state number to the final state number and the new map
53 PassState f = traverse asState map
54 -- Run this function to get the new map
56 -- This function maps each element to a State with a unique number, by
57 -- incrementing the state count.
58 asState x = PassState (\s -> (s+1, State s))
60 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
61 -- which all the Single elements are marked as Port.
62 useAsPort :: HsValueMap a -> HsUseMap
63 useAsPort map = fmap (\x -> Port) map
65 -- | A Haskell function with a specific signature. The signature defines what
66 -- use the arguments and return value of the function get.
67 data HsFunction = HsFunction {
69 hsFuncArgs :: [HsUseMap],
71 } deriving (Show, Eq, Ord)
73 hasState :: HsFunction -> Bool
75 any (Foldable.any isStateUse) (hsFuncArgs hsfunc)
76 || Foldable.any isStateUse (hsFuncRes hsfunc)
78 -- | Something that defines a signal
80 -- | A flattened function application
82 appFunc :: HsFunction,
83 appArgs :: [SignalMap],
86 -- | A conditional signal definition
93 -- | Unconditional signal definition
95 defSrc :: Either SignalId SignalExpr,
99 -- | Is the given SigDef a FApp?
100 is_FApp :: SigDef -> Bool
101 is_FApp d = case d of
105 -- | Which signals are used by the given SigDef?
106 sigDefUses :: SigDef -> [SignalId]
107 sigDefUses (UncondDef (Left id) _) = [id]
108 sigDefUses (UncondDef (Right expr) _) = sigExprUses expr
109 sigDefUses (CondDef cond true false _) = [cond, true, false]
110 sigDefUses (FApp _ args _) = concat $ map Foldable.toList args
112 -- | An expression on signals
114 EqLit SignalId String -- ^ Is the given signal equal to the given (VHDL) literal
115 | Literal String -- ^ A literal value
116 | Eq SignalId SignalId -- ^ A comparison between to signals
119 -- | Which signals are used by the given SignalExpr?
120 sigExprUses :: SignalExpr -> [SignalId]
121 sigExprUses (EqLit id _) = [id]
122 sigExprUses (Literal _) = []
123 sigExprUses (Eq a b) = [a, b]
125 -- Returns the function used by the given SigDef, if any
126 usedHsFunc :: SigDef -> Maybe HsFunction
127 usedHsFunc (FApp hsfunc _ _) = Just hsfunc
128 usedHsFunc _ = Nothing
130 -- | How is a given signal used in the resulting VHDL?
132 SigPortIn -- | Use as an input port
133 | SigPortOut -- | Use as an input port
134 | SigInternal -- | Use as an internal signal
135 | SigStateOld StateId -- | Use as the current internal state
136 | SigStateNew StateId -- | Use as the new internal state
137 | SigSubState -- | Do not use, state variable is used in a subcircuit
139 -- | Is this a port signal use?
140 isPortSigUse :: SigUse -> Bool
141 isPortSigUse SigPortIn = True
142 isPortSigUse SigPortOut = True
143 isPortSigUse _ = False
145 -- | Is this a state signal use? Returns false for substate.
146 isStateSigUse :: SigUse -> Bool
147 isStateSigUse (SigStateOld _) = True
148 isStateSigUse (SigStateNew _) = True
149 isStateSigUse _ = False
151 -- | Is this an internal signal use?
152 isInternalSigUse :: SigUse -> Bool
153 isInternalSigUse SigInternal = True
154 isInternalSigUse _ = False
156 oldStateId :: SigUse -> Maybe StateId
157 oldStateId (SigStateOld id) = Just id
158 oldStateId _ = Nothing
160 newStateId :: SigUse -> Maybe StateId
161 newStateId (SigStateNew id) = Just id
162 newStateId _ = Nothing
164 -- | Information on a signal definition
165 data SignalInfo = SignalInfo {
166 sigName :: Maybe String,
169 nameHints :: [String]
172 -- | A flattened function
173 data FlatFunction = FlatFunction {
174 flat_args :: [SignalMap],
175 flat_res :: SignalMap,
176 flat_defs :: [SigDef],
177 flat_sigs :: [(SignalId, SignalInfo)]
180 -- | Lookup a given signal id in a signal map, and return the associated
181 -- SignalInfo. Errors out if the signal was not found.
182 signalInfo :: [(SignalId, SignalInfo)] -> SignalId -> SignalInfo
183 signalInfo sigs id = Maybe.fromJust $ lookup id sigs
185 -- | A list of binds in effect at a particular point of evaluation
187 CoreBndr, -- ^ The bind name
188 BindValue -- ^ The value bound to it
192 Either -- ^ The bind value which is either
196 HsValueUse, -- ^ or a HighOrder function
197 [SignalId] -- ^ With these signals already applied to it
200 -- | The state during the flattening of a single function
201 type FlattenState = State.State ([SigDef], [(SignalId, SignalInfo)], SignalId)
203 -- | Add an application to the current FlattenState
204 addDef :: SigDef -> FlattenState ()
206 (defs, sigs, n) <- State.get
207 State.put (d:defs, sigs, n)
209 -- | Generates a new signal id, which is unique within the current flattening.
210 genSignalId :: SigUse -> Type.Type -> FlattenState SignalId
211 genSignalId use ty = do
212 (defs, sigs, n) <- State.get
213 -- Generate a new numbered but unnamed signal
214 let s = (n, SignalInfo Nothing use ty [])
215 State.put (defs, s:sigs, n+1)
218 -- | Add a name hint to the given signal
219 addNameHint :: String -> SignalId -> FlattenState ()
220 addNameHint hint id = do
221 info <- getSignalInfo id
222 let hints = nameHints info
227 let hints' = (hint:hints)
228 setSignalInfo id (info {nameHints = hints'})
230 -- | Returns the SignalInfo for the given signal. Errors if the signal is not
231 -- known in the session.
232 getSignalInfo :: SignalId -> FlattenState SignalInfo
233 getSignalInfo id = do
234 (defs, sigs, n) <- State.get
235 return $ signalInfo sigs id
237 setSignalInfo :: SignalId -> SignalInfo -> FlattenState ()
238 setSignalInfo id' info' = do
239 (defs, sigs, n) <- State.get
240 let sigs' = map (\(id, info) -> (id, if id == id' then info' else info)) sigs
241 State.put (defs, sigs', n)
243 -- vim: set ts=8 sw=2 sts=2 expandtab: