- )
-
-getPortMapEntry ::
- PortNameMap -- The port name to bind to
- -> AST.VHDLName -- 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 (Port portname) signame =
- (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName signame)
-
-getInstantiations ::
- [PortNameMap] -- The arguments that need to be applied to the
- -- expression.
- -> PortNameMap -- The output ports that the expression should generate.
- -> [(CoreBndr, PortNameMap)] -- 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 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 (AST.unsafeVHDLBasicId name)))
- (AST.PMapAspect (inmaps ++ outmaps))
- return (sigs, (AST.CSISm comp) : comps)
-
-getInstantiations args outs binds expr =
- error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-
-expandArgs ::
- [(CoreBndr, PortNameMap)] -- A list of bindings in effect
- -> [CoreExpr] -- The arguments to expand
- -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])
- -- The resulting signal declarations,
- -- component instantiations and a
- -- VHDLName for each of the
- -- expressions passed in.
-expandArgs binds (e:exprs) = do
- -- Expand the first expression
- arg <- case e of
- -- A simple variable reference should be in our binds map
- Var id -> return $ let
- -- Lookup the id in our binds map
- Port signalname = Maybe.fromMaybe
- (error $ "Argument " ++ getOccString id ++ "is unknown")
- (lookup id binds)
- in
- -- Create a VHDL name from the signal name
- AST.NSimple (AST.unsafeVHDLBasicId signalname)
- -- Other expressions are unsupported
- otherwise -> error ("Unsupported expression used as argument: " ++ (showSDoc $ ppr e))
- -- Expand the rest
- (sigs, comps, args) <- expandArgs binds exprs
- -- Return all results
- return (sigs, comps, arg:args)
-
-expandArgs _ [] = return ([], [], [])
-
--- Is the given name a (binary) tuple constructor
-isTupleConstructor :: Var.Var -> Bool
-isTupleConstructor var =
- Name.isWiredInName name
- && Name.nameModule name == tuple_mod
- && (Name.occNameString $ Name.nameOccName name) == "(,)"
- where
- name = Var.varName var
- mod = nameModule name
- tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
-
--- Split arguments into type arguments and value arguments This is probably
--- not really sufficient (not sure if Types can actually occur as value
--- arguments...)
-splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
-splitTupleConstructorArgs (e:es) =
- case e of
- Type t -> (e:tys, vals)
- otherwise -> (tys, e:vals)
+ ) binds
+
+-- | Processes the given bind as a top level bind.
+processBind ::
+ CoreBind -- The bind to process
+ -> VHDLState ()
+
+processBind (Rec _) = error "Recursive binders not supported"
+processBind bind@(NonRec var expr) = do
+ -- Create the function signature
+ let ty = CoreUtils.exprType expr
+ let hsfunc = mkHsFunction var ty
+ 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
+ -> CoreBind -- The bind to flatten
+ -> VHDLState ()
+
+flattenBind _ (Rec _) = error "Recursive binders not supported"
+
+flattenBind hsfunc bind@(NonRec var expr) = do
+ -- Flatten the function
+ let flatfunc = flattenFunction hsfunc bind
+ addFunc hsfunc
+ setFlatFunc hsfunc flatfunc
+ let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc)
+ State.mapM resolvFunc used_hsfuncs
+ return ()
+
+-- | Find the given function, flatten it and add it to the session. Then
+-- (recursively) do the same for any functions used.
+resolvFunc ::
+ HsFunction -- | The function to look for
+ -> VHDLState ()
+
+resolvFunc hsfunc = do
+ -- See if the function is already known
+ func <- getFunc hsfunc
+ case func of
+ -- Already known, do nothing
+ Just _ -> do
+ return ()
+ -- New function, resolve it
+ Nothing -> do
+ -- Get the current module
+ core <- getModule
+ -- Find the named function
+ let bind = findBind (cm_binds core) name
+ case bind of
+ Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+ Just b -> flattenBind hsfunc b