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]
22 -- | Creates a HsValueMap with the same structure as the given type, using the
23 -- given function for mapping the single types.
25 Type.Type -- ^ The type to map to a HsValueMap
26 -> HsValueMap Type.Type -- ^ The resulting map and state
29 case Type.splitTyConApp_maybe ty of
31 if (TyCon.isTupleTyCon tycon)
33 Tuple (map mkHsValueMap args)
38 -- Extract the arguments from a data constructor application (that is, the
39 -- normal args, leaving out the type args).
40 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
41 dataConAppArgs dc args =
44 tycount = length $ DataCon.dataConAllTyVars dc
48 data FlatFunction = FlatFunction {
49 args :: [SignalDefMap],
51 --sigs :: [SignalDef],
56 type SignalUseMap = HsValueMap SignalUse
57 type SignalDefMap = HsValueMap SignalDef
59 useMapToDefMap :: SignalUseMap -> SignalDefMap
60 useMapToDefMap (Single (SignalUse u)) = Single (SignalDef u)
61 useMapToDefMap (Tuple uses) = Tuple (map useMapToDefMap uses)
64 data SignalUse = SignalUse {
68 data SignalDef = SignalDef {
73 appFunc :: HsFunction,
74 appArgs :: [SignalUseMap],
75 appRes :: SignalDefMap
78 data CondDef = CondDef {
85 -- | How is a given (single) value in a function's type (ie, argument or
86 -- return value) used?
88 Port -- ^ Use it as a port (input or output)
89 | State Int -- ^ Use it as state (input or output). The int is used to
90 -- match input state to output state.
91 | HighOrder { -- ^ Use it as a high order function input
92 hoName :: String, -- ^ Which function is passed in?
93 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
94 -- ^ map should only contain Port and other
99 type HsUseMap = HsValueMap HsValueUse
101 data HsFunction = HsFunction {
102 hsFuncName :: String,
103 hsFuncArgs :: [HsUseMap],
104 hsFuncRes :: HsUseMap
105 } deriving (Show, Eq)
108 CoreBndr, -- ^ The bind name
109 Either -- ^ The bind value which is either
110 SignalUseMap -- ^ a signal
112 HsValueUse, -- ^ or a HighOrder function
113 [SignalUse] -- ^ With these signals already applied to it
117 type FlattenState = State.State ([FApp], [CondDef], SignalId)
119 -- | Add an application to the current FlattenState
120 addApp :: FApp -> FlattenState ()
122 (apps, conds, n) <- State.get
123 State.put (a:apps, conds, n)
125 -- | Add a conditional definition to the current FlattenState
126 addCondDef :: CondDef -> FlattenState ()
128 (apps, conds, n) <- State.get
129 State.put (apps, c:conds, n)
131 -- | Generates a new signal id, which is unique within the current flattening.
132 genSignalId :: FlattenState SignalId
134 (apps, conds, n) <- State.get
135 State.put (apps, conds, n+1)
140 -> FlattenState SignalUseMap
142 genSignalUses ty = do
143 typeMapToUseMap tymap
145 -- First generate a map with the right structure containing the types
146 tymap = mkHsValueMap ty
150 -> FlattenState SignalUseMap
152 typeMapToUseMap (Single ty) = do
154 return $ Single (SignalUse id)
156 typeMapToUseMap (Tuple tymaps) = do
157 usemaps <- mapM typeMapToUseMap tymaps
158 return $ Tuple usemaps
160 -- | Flatten a haskell function
162 HsFunction -- ^ The function to flatten
163 -> CoreBind -- ^ The function value
164 -> FlatFunction -- ^ The resulting flat function
166 flattenFunction _ (Rec _) = error "Recursive binders not supported"
167 flattenFunction hsfunc bind@(NonRec var expr) =
168 FlatFunction args res apps conds
170 init_state = ([], [], 0)
171 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
173 (apps, conds, _) = end_state
178 -> FlattenState ([SignalDefMap], SignalUseMap)
180 flattenExpr binds lam@(Lam b expr) = do
181 -- Find the type of the binder
182 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
183 -- Create signal names for the binder
184 defs <- genSignalUses arg_ty
185 let binds' = (b, Left defs):binds
186 (args, res) <- flattenExpr binds' expr
187 return ((useMapToDefMap defs) : args, res)
189 flattenExpr binds (Var id) =
191 Left sig_use -> return ([], sig_use)
192 Right _ -> error "Higher order functions not supported."
194 bind = Maybe.fromMaybe
195 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
198 flattenExpr binds app@(App _ _) = do
199 -- Is this a data constructor application?
200 case CoreUtils.exprIsConApp_maybe app of
201 -- Is this a tuple construction?
202 Just (dc, args) -> if DataCon.isTupleCon dc
204 flattenBuildTupleExpr binds (dataConAppArgs dc args)
206 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
208 -- Normal function application
209 let ((Var f), args) = collectArgs app in
210 flattenApplicationExpr binds (CoreUtils.exprType app) f args
212 flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
213 flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
216 return ([], Tuple [])
219 -- vim: set ts=8 sw=2 sts=2 expandtab: