-getPortMapEntry binds portname (Var id) =
- "\t" ++ portname ++ " => " ++ signalname ++ "\n"
- where
- Port signalname = Maybe.fromMaybe
- (error $ "Argument " ++ getOccString id ++ "is unknown")
- (lookup id binds)
-
-getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
-
-getInstantiations ::
- PortNameMap -- The arguments that need to be applied to the
- -- expression. Should always be the Args
- -- constructor.
- -> 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
- -> String -- The resulting VHDL code
-
--- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (Args (a:as)) outs binds (Lam b expr) =
- getInstantiations (Args 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]) =
- case altcon of
- DataAlt datacon ->
- if (DataCon.isTupleCon datacon) then
- getInstantiations args outs binds' expr
- else
- error "Data constructors other than tuples not supported"
- otherwise ->
- error "Case binders other than tuples not supported"
- where
- binds' = (zip bind_vars tuple_ports) ++ binds
- (altcon, bind_vars, expr) = res
- -- Find the portnamemaps for each of the tuple's elements
- Tuple tuple_ports = Maybe.fromMaybe
- (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
- (lookup v binds)
-
--- An application is an instantiation of a component
-getInstantiations args outs binds app@(App expr arg) =
- if isTupleConstructor f then
- let
- Tuple outports = outs
- (tys, vals) = splitTupleConstructorArgs fargs
- in
- concat $ zipWith
- (\outs' expr' -> getInstantiations args outs' binds expr')
- outports vals
- else
- --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
- "app : " ++ (getOccString f) ++ "\n"
- ++ "port map (\n"
- -- Map input ports of f
- ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] fargs)
- -- Map output ports of f
- ++ mapOutputPorts (Port "portout") outs
- ++ ");\n"
- where
- ((Var f), fargs) = collectArgs app
-
-getInstantiations args outs binds expr =
- error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-
--- 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)
- where
- (tys, vals) = splitTupleConstructorArgs es
+getPortMapEntry (Single (portname, _)) (Single (signame, _)) =
+ (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
+expandExpr ::
+ [(CoreBndr, SignalNameMap)]
+ -- 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], -- The signal names corresponding to
+ -- the expression's arguments
+ SignalNameMap) -- 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 ([], [], [], Single (signal_id, ty))
+ where
+ -- Lookup the id in our binds map
+ Single (signal_id, ty) = Maybe.fromMaybe
+ (error $ "Argument " ++ getOccString id ++ "is unknown")
+ (lookup id binds)
+
+expandExpr binds l@(Let (NonRec b bexpr) expr) = do
+ (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
+ let binds' = (b, res_signals) : binds
+ (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
+ return (
+ signal_decls ++ signal_decls',
+ statements ++ statements',
+ arg_signals',
+ res_signals')
+
+expandExpr binds app@(App _ _) = do
+ -- Is this a data constructor application?
+ case CoreUtils.exprIsConApp_maybe app of
+ -- Is this a tuple construction?
+ Just (dc, args) -> if DataCon.isTupleCon dc
+ then
+ expandBuildTupleExpr binds (dataConAppArgs dc args)
+ else
+ error "Data constructors other than tuples not supported"
+ otherise ->
+ -- Normal function application, should map to a component instantiation
+ let ((Var f), args) = collectArgs app in
+ expandApplicationExpr binds (CoreUtils.exprType app) f args
+
+expandExpr binds expr@(Case (Var v) b _ alts) =
+ case alts of
+ [alt] -> expandSingleAltCaseExpr binds v b alt
+ otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
+
+expandExpr binds expr@(Case _ b _ _) =
+ error $ "Case expression with non-variable scrutinee not supported: " ++ (showSDoc $ ppr expr)
+
+expandExpr binds expr =
+ error $ "Unsupported expression: " ++ (showSDoc $ ppr $ expr)
+
+-- Expands the construction of a tuple into VHDL
+expandBuildTupleExpr ::
+ [(CoreBndr, SignalNameMap)]
+ -- A list of bindings in effect
+ -> [CoreExpr] -- A list of expressions to put in the tuple
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
+ -- See expandExpr
+expandBuildTupleExpr binds args = do
+ -- Split the tuple constructor arguments into types and actual values.
+ -- Expand each of the values in the tuple
+ (signals_declss, statementss, arg_signalss, res_signals) <-
+ (Monad.liftM List.unzip4) $ mapM (expandExpr binds) args
+ if any (not . null) arg_signalss
+ then error "Putting high order functions in tuples not supported"
+ else
+ return (
+ concat signals_declss,
+ concat statementss,
+ [],
+ Tuple res_signals)
+
+-- Expands the most simple case expression that scrutinizes a plain variable
+-- and has a single alternative. This simple form currently allows only for
+-- unpacking tuple variables.
+expandSingleAltCaseExpr ::
+ [(CoreBndr, SignalNameMap)]
+ -- A list of bindings in effect
+ -> Var.Var -- The scrutinee
+ -> CoreBndr -- The binder to bind the scrutinee to
+ -> CoreAlt -- The single alternative
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
+ -- See expandExpr
+
+expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
+ if not (DataCon.isTupleCon datacon)
+ then
+ error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
+ else
+ 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)
+ -- TODO include b in the binds list
+ -- Merge our existing binds with the new binds.
+ binds' = (zip bind_vars tuple_ports) ++ binds
+ in
+ -- Expand the expression with the new binds list
+ expandExpr binds' expr
+
+expandSingleAltCaseExpr _ _ _ alt =
+ error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
+
+
+-- Expands the application of argument to a function into VHDL
+expandApplicationExpr ::
+ [(CoreBndr, SignalNameMap)]
+ -- A list of bindings in effect
+ -> Type -- The result type of the function call
+ -> Var.Var -- The function to call
+ -> [CoreExpr] -- A list of argumetns to apply to the function
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
+ -- See expandExpr
+expandApplicationExpr binds ty f args = do
+ let name = getOccString f
+ -- Generate a unique name for the application
+ appname <- uniqueName ("app_" ++ name)
+ -- Lookup the hwfunction to instantiate
+ HWFunction vhdl_id inports outport <- getHWFunc (appToHsFunction f args ty)
+ -- Expand each of the args, so each of them is reduced to output signals
+ (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
+ -- Bind each of the input ports to the expanded arguments
+ let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
+ -- Create signal names for our result
+ let res_signal = getPortNameMapForTy (appname ++ "_out") ty
+ -- Create the corresponding signal declarations
+ let signal_decls = mkSignalsFromMap res_signal
+ -- Bind each of the output ports to our output signals
+ let outmaps = mapOutputPorts outport res_signal
+ -- Instantiate the component
+ let component = AST.CSISm $ AST.CompInsSm
+ (AST.unsafeVHDLBasicId appname)
+ (AST.IUEntity (AST.NSimple vhdl_id))
+ (AST.PMapAspect (inmaps ++ outmaps))
+ -- Merge the generated declarations
+ return (
+ signal_decls ++ arg_signal_decls,
+ component : arg_statements,
+ [], -- We don't take any extra arguments; we don't support higher order functions yet
+ res_signal)
+
+-- Creates a list of AssocElems (port map lines) that maps the given signals
+-- to the given ports.
+createAssocElems ::
+ SignalNameMap -- The port names to bind to
+ -> SignalNameMap -- The signals to bind to it
+ -> [AST.AssocElem] -- The resulting port map lines
+
+createAssocElems (Single (port_id, _)) (Single (signal_id, _)) =
+ [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
+
+createAssocElems (Tuple ports) (Tuple signals) =
+ concat $ zipWith createAssocElems ports signals
+
+-- Generate a signal declaration for a signal with the given name and the
+-- given type and no value. Also returns the id of the signal.
+mkSignal :: String -> AST.TypeMark -> (AST.VHDLId, AST.SigDec)
+mkSignal name ty =
+ (id, mkSignalFromId id ty)
+ where
+ id = AST.unsafeVHDLBasicId name
+
+mkSignalFromId :: AST.VHDLId -> AST.TypeMark -> AST.SigDec
+mkSignalFromId id ty =
+ AST.SigDec id ty Nothing
+
+-- Generates signal declarations for all the signals in the given map
+mkSignalsFromMap ::
+ SignalNameMap
+ -> [AST.SigDec]
+
+mkSignalsFromMap (Single (id, ty)) =
+ [mkSignalFromId id ty]
+
+mkSignalsFromMap (Tuple signals) =
+ concat $ map mkSignalsFromMap signals
+
+expandArgs ::
+ [(CoreBndr, SignalNameMap)] -- A list of bindings in effect
+ -> [CoreExpr] -- The arguments to expand
+ -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap])
+ -- 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
+ (signal_decls, statements, arg_signals, res_signal) <- expandExpr binds e
+ if not (null arg_signals)
+ then error $ "Passing functions as arguments not supported: " ++ (showSDoc $ ppr e)
+ else do
+ (signal_decls', statements', res_signals') <- expandArgs binds exprs
+ return (
+ signal_decls ++ signal_decls',
+ statements ++ statements',
+ res_signal : res_signals')
+
+expandArgs _ [] = return ([], [], [])
+
+-- Extract the arguments from a data constructor application (that is, the
+-- normal args, leaving out the type args).
+dataConAppArgs :: DataCon -> [CoreExpr] -> [CoreExpr]
+dataConAppArgs dc args =
+ drop tycount args
+ where
+ tycount = length $ DataCon.dataConAllTyVars dc
+
+mapOutputPorts ::
+ SignalNameMap -- The output portnames of the component
+ -> SignalNameMap -- The output portnames and/or signals to map these to
+ -> [AST.AssocElem] -- The resulting output ports