7 import qualified DataCon
8 import qualified CoreUtils
9 import Outputable ( showSDoc, ppr )
10 import qualified Control.Monad.State as State
12 -- | A datatype that maps each of the single values in a haskell structure to
13 -- a mapto. The map has the same structure as the haskell type mapped, ie
15 data HsValueMap mapto =
16 Tuple [HsValueMap mapto]
20 instance Functor HsValueMap where
21 fmap f (Single s) = Single (f s)
22 fmap f (Tuple maps) = Tuple (fmap (fmap f) maps)
24 -- | Creates a HsValueMap with the same structure as the given type, using the
25 -- given function for mapping the single types.
27 Type.Type -- ^ The type to map to a HsValueMap
28 -> HsValueMap Type.Type -- ^ The resulting map and state
31 case Type.splitTyConApp_maybe ty of
33 if (TyCon.isTupleTyCon tycon)
35 Tuple (map mkHsValueMap args)
40 -- Extract the arguments from a data constructor application (that is, the
41 -- normal args, leaving out the type args).
42 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
43 dataConAppArgs dc args =
46 tycount = length $ DataCon.dataConAllTyVars dc
50 data FlatFunction = FlatFunction {
51 args :: [SignalDefMap],
53 --sigs :: [SignalDef],
58 type SignalUseMap = HsValueMap SignalUse
59 type SignalDefMap = HsValueMap SignalDef
61 useMapToDefMap :: SignalUseMap -> SignalDefMap
62 useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u)
65 data SignalUse = SignalUse {
69 data SignalDef = SignalDef {
74 appFunc :: HsFunction,
75 appArgs :: [SignalUseMap],
76 appRes :: SignalDefMap
79 data CondDef = CondDef {
86 -- | How is a given (single) value in a function's type (ie, argument or
87 -- return value) used?
89 Port -- ^ Use it as a port (input or output)
90 | State Int -- ^ Use it as state (input or output). The int is used to
91 -- match input state to output state.
92 | HighOrder { -- ^ Use it as a high order function input
93 hoName :: String, -- ^ Which function is passed in?
94 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
95 -- ^ map should only contain Port and other
100 type HsUseMap = HsValueMap HsValueUse
102 data HsFunction = HsFunction {
103 hsFuncName :: String,
104 hsFuncArgs :: [HsUseMap],
105 hsFuncRes :: HsUseMap
106 } deriving (Show, Eq)
109 CoreBndr, -- ^ The bind name
110 Either -- ^ The bind value which is either
111 SignalUseMap -- ^ a signal
113 HsValueUse, -- ^ or a HighOrder function
114 [SignalUse] -- ^ With these signals already applied to it
118 type FlattenState = State.State ([FApp], [CondDef], SignalId)
120 -- | Add an application to the current FlattenState
121 addApp :: FApp -> FlattenState ()
123 (apps, conds, n) <- State.get
124 State.put (a:apps, conds, n)
126 -- | Add a conditional definition to the current FlattenState
127 addCondDef :: CondDef -> FlattenState ()
129 (apps, conds, n) <- State.get
130 State.put (apps, c:conds, n)
132 -- | Generates a new signal id, which is unique within the current flattening.
133 genSignalId :: FlattenState SignalId
135 (apps, conds, n) <- State.get
136 State.put (apps, conds, n+1)
141 -> FlattenState SignalUseMap
143 genSignalUses ty = do
144 typeMapToUseMap tymap
146 -- First generate a map with the right structure containing the types
147 tymap = mkHsValueMap ty
151 -> FlattenState SignalUseMap
153 typeMapToUseMap (Single ty) = do
155 return $ Single (SignalUse id)
157 typeMapToUseMap (Tuple tymaps) = do
158 usemaps <- mapM typeMapToUseMap tymaps
159 return $ Tuple usemaps
161 -- | Flatten a haskell function
163 HsFunction -- ^ The function to flatten
164 -> CoreBind -- ^ The function value
165 -> FlatFunction -- ^ The resulting flat function
167 flattenFunction _ (Rec _) = error "Recursive binders not supported"
168 flattenFunction hsfunc bind@(NonRec var expr) =
169 FlatFunction args res apps conds
171 init_state = ([], [], 0)
172 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
174 (apps, conds, _) = end_state
179 -> FlattenState ([SignalDefMap], SignalUseMap)
181 flattenExpr binds lam@(Lam b expr) = do
182 -- Find the type of the binder
183 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
184 -- Create signal names for the binder
185 defs <- genSignalUses arg_ty
186 let binds' = (b, Left defs):binds
187 (args, res) <- flattenExpr binds' expr
188 return ((useMapToDefMap defs) : args, res)
190 flattenExpr binds (Var id) =
192 Left sig_use -> return ([], sig_use)
193 Right _ -> error "Higher order functions not supported."
195 bind = Maybe.fromMaybe
196 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
199 flattenExpr binds app@(App _ _) = do
200 -- Is this a data constructor application?
201 case CoreUtils.exprIsConApp_maybe app of
202 -- Is this a tuple construction?
203 Just (dc, args) -> if DataCon.isTupleCon dc
205 flattenBuildTupleExpr binds (dataConAppArgs dc args)
207 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
209 -- Normal function application
210 let ((Var f), args) = collectArgs app in
211 flattenApplicationExpr binds (CoreUtils.exprType app) f args
213 flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
214 flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
217 return ([], Tuple [])
220 -- vim: set ts=8 sw=2 sts=2 expandtab: