- find (\b -> case b of
- Rec l -> False
- NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
- ) binds
-
-getPortMapEntry ::
- SignalNameMap AST.VHDLId -- The port name to bind to
- -> SignalNameMap AST.VHDLId
- -- The signal or port to bind to it
- -> AST.AssocElem -- The resulting port map entry
-
--- Accepts a port name and an argument to map to it.
--- Returns the appropriate line for in the port map
-getPortMapEntry (Signal portname) (Signal signame) =
- (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
-
-getInstantiations ::
- [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
- -- expression.
- -> SignalNameMap AST.VHDLId -- The output ports that the expression should generate.
- -> [(CoreBndr, SignalNameMap AST.VHDLId)]
- -- A list of bindings in effect
- -> CoreSyn.CoreExpr -- The expression to generate an architecture for
- -> VHDLState ([AST.SigDec], [AST.ConcSm])
- -- The resulting VHDL code
-
--- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (a:as) outs binds (Lam b expr) =
- getInstantiations as outs ((b, a):binds) expr
-
--- A case expression that checks a single variable and has a single
--- alternative, can be used to take tuples apart
-getInstantiations args outs binds (Case (Var v) b _ [res]) =
- -- Split out the type of alternative constructor, the variables it binds
- -- and the expression to evaluate with the variables bound.
- let (altcon, bind_vars, expr) = res in
- case altcon of
- DataAlt datacon ->
- if (DataCon.isTupleCon datacon) then
- let
- -- Lookup the scrutinee (which must be a variable bound to a tuple) in
- -- the existing bindings list and get the portname map for each of
- -- it's elements.
- Tuple tuple_ports = Maybe.fromMaybe
- (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
- (lookup v binds)
- -- Merge our existing binds with the new binds.
- binds' = (zip bind_vars tuple_ports) ++ binds
- in
- -- Evaluate the expression with the new binds list
- getInstantiations args outs binds' expr
- else
- error "Data constructors other than tuples not supported"
- otherwise ->
- error "Case binders other than tuples not supported"
-
--- An application is an instantiation of a component
-getInstantiations args outs binds app@(App expr arg) = do
- let ((Var f), fargs) = collectArgs app
- name = getOccString f
- if isTupleConstructor f
- then do
- -- Get the signals we should bind our results to
- let Tuple outports = outs
- -- Split the tuple constructor arguments into types and actual values.
- let (_, vals) = splitTupleConstructorArgs fargs
- -- Bind each argument to each output signal
- res <- sequence $ zipWith
- (\outs' expr' -> getInstantiations args outs' binds expr')
- outports vals
- -- res is a list of pairs of lists, so split out the signals and
- -- components into separate lists of lists
- let (sigs, comps) = unzip res
- -- And join all the signals and component instantiations together
- return $ (concat sigs, concat comps)
- else do
- -- This is an normal function application, which maps to a component
- -- instantiation.
- -- Lookup the hwfunction to instantiate
- HWFunction vhdl_id inports outport <- getHWFunc name
- -- Generate a unique name for the application
- appname <- uniqueName "app"
- -- Expand each argument to a signal or port name, possibly generating
- -- new signals and component instantiations
- (sigs, comps, args) <- expandArgs binds fargs
- -- Bind each of the input ports to the expanded signal or port
- let inmaps = zipWith getPortMapEntry inports args
- -- Bind each of the output ports to our output signals
- let outmaps = mapOutputPorts outport outs
- -- Build and return a component instantiation
- let comp = AST.CompInsSm
- (AST.unsafeVHDLBasicId appname)
- (AST.IUEntity (AST.NSimple vhdl_id))
- (AST.PMapAspect (inmaps ++ outmaps))
- return (sigs, (AST.CSISm comp) : comps)
-
-getInstantiations args outs binds expr =
- error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-
-expandExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
- -- A list of bindings in effect
- -> CoreExpr -- The expression to expand
- -> VHDLState (
- [AST.SigDec], -- Needed signal declarations
- [AST.ConcSm], -- Needed component instantations and
- -- signal assignments.
- [SignalNameMap AST.VHDLId], -- The signal names corresponding to
- -- the expression's arguments
- SignalNameMap AST.VHDLId) -- The signal names corresponding to
- -- the expression's result.
-expandExpr binds lam@(Lam b expr) = do
- -- Generate a new signal to which we will expect this argument to be bound.
- signal_name <- uniqueName ("arg-" ++ getOccString b)
- -- Find the type of the binder
- let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
- -- Create signal names for the binder
- let arg_signal = getPortNameMapForTy ("xxx") arg_ty
- -- Create the corresponding signal declarations
- let signal_decls = mkSignalsFromMap arg_signal
- -- Add the binder to the list of binds
- let binds' = (b, arg_signal) : binds
- -- Expand the rest of the expression
- (signal_decls', statements', arg_signals', res_signal') <- expandExpr binds' expr
- -- Properly merge the results
- return (signal_decls ++ signal_decls',
- statements',
- arg_signal : arg_signals',
- res_signal')
-
-expandExpr binds (Var id) =
- return ([], [], [], Signal signal_id)
+ find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
+
+-- | Processes the given bind as a top level bind.
+processBind ::
+ Bool -- ^ Should this be stateful function?
+ -> (CoreBndr, CoreExpr) -- ^ The bind to process
+ -> TranslatorState ()
+
+processBind stateful bind@(var, expr) = do
+ -- Create the function signature
+ let ty = CoreUtils.exprType expr
+ let hsfunc = mkHsFunction var ty stateful
+ flattenBind hsfunc bind
+
+-- | Flattens the given bind into the given signature and adds it to the
+-- session. Then (recursively) finds any functions it uses and does the same
+-- with them.
+flattenBind ::
+ HsFunction -- The signature to flatten into
+ -> (CoreBndr, CoreExpr) -- The bind to flatten
+ -> TranslatorState ()
+
+flattenBind hsfunc bind@(var, expr) = do
+ -- Flatten the function
+ let flatfunc = flattenFunction hsfunc bind
+ -- Propagate state variables
+ let flatfunc' = propagateState hsfunc flatfunc
+ -- Store the flat function in the session
+ modA tsFlatFuncs (Map.insert hsfunc flatfunc')
+ -- Flatten any functions used
+ let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
+ mapM_ resolvFunc used_hsfuncs
+
+-- | Decide which incoming state variables will become state in the
+-- given function, and which will be propagate to other applied
+-- functions.
+propagateState ::
+ HsFunction
+ -> FlatFunction
+ -> FlatFunction
+
+propagateState hsfunc flatfunc =
+ flatfunc {flat_defs = apps', flat_sigs = sigs'}