-- ForSyDe to get access to these modules.
import qualified ForSyDe.Backend.VHDL.AST as AST
import qualified ForSyDe.Backend.VHDL.Ppr
+import qualified ForSyDe.Backend.VHDL.FileIO
import qualified ForSyDe.Backend.Ppr
-- This is needed for rendering the pretty printed VHDL
import Text.PrettyPrint.HughesPJ (render)
-- Turn bind into VHDL
let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 [])
liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
+ liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
return ()
where
-- Turns the given bind into VHDL
) binds
getPortMapEntry ::
- SignalNameMap AST.VHDLId -- The port name to bind to
- -> SignalNameMap AST.VHDLId
+ SignalNameMap -- The port name to bind to
+ -> SignalNameMap
-- 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) =
+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
+ [SignalNameMap] -- 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)]
+ -> SignalNameMap -- The output ports that the expression should generate.
+ -> [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> CoreSyn.CoreExpr -- The expression to generate an architecture for
-> VHDLState ([AST.SigDec], [AST.ConcSm])
error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
expandExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(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 AST.VHDLId], -- The signal names corresponding to
+ [SignalNameMap], -- The signal names corresponding to
-- the expression's arguments
- SignalNameMap AST.VHDLId) -- The signal names corresponding to
+ 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)
+ 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
res_signal')
expandExpr binds (Var id) =
- return ([], [], [], Signal signal_id)
+ return ([], [], [], Signal signal_id ty)
where
-- Lookup the id in our binds map
- Signal signal_id = Maybe.fromMaybe
+ Signal signal_id ty = Maybe.fromMaybe
(error $ "Argument " ++ getOccString id ++ "is unknown")
(lookup id binds)
-- Expands the construction of a tuple into VHDL
expandBuildTupleExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(CoreBndr, SignalNameMap)]
-- A list of bindings in effect
-> [CoreExpr] -- A list of expressions to put in the tuple
- -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
-- See expandExpr
expandBuildTupleExpr binds args = do
-- Split the tuple constructor arguments into types and actual values.
-- and has a single alternative. This simple form currently allows only for
-- unpacking tuple variables.
expandSingleAltCaseExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(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 AST.VHDLId], SignalNameMap AST.VHDLId)
+ -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
-- See expandExpr
expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
-- Expands the application of argument to a function into VHDL
expandApplicationExpr ::
- [(CoreBndr, SignalNameMap AST.VHDLId)]
+ [(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 AST.VHDLId], SignalNameMap AST.VHDLId)
+ -> 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)
+ appname <- uniqueName ("app_" ++ name)
-- Lookup the hwfunction to instantiate
HWFunction vhdl_id inports outport <- getHWFunc name
-- Expand each of the args, so each of them is reduced to output signals
-- 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
+ 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
-- Creates a list of AssocElems (port map lines) that maps the given signals
-- to the given ports.
createAssocElems ::
- SignalNameMap AST.VHDLId -- The port names to bind to
- -> SignalNameMap AST.VHDLId -- The signals to bind to it
+ SignalNameMap -- The port names to bind to
+ -> SignalNameMap -- The signals to bind to it
-> [AST.AssocElem] -- The resulting port map lines
-createAssocElems (Signal port_id) (Signal signal_id) =
+createAssocElems (Signal port_id _) (Signal signal_id _) =
[(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
createAssocElems (Tuple ports) (Tuple signals) =
-- Generates signal declarations for all the signals in the given map
mkSignalsFromMap ::
- SignalNameMap AST.VHDLId
+ SignalNameMap
-> [AST.SigDec]
-mkSignalsFromMap (Signal id) =
- -- TODO: This uses the bit type hardcoded
- [mkSignalFromId id vhdl_bit_ty]
+mkSignalsFromMap (Signal id ty) =
+ [mkSignalFromId id ty]
mkSignalsFromMap (Tuple signals) =
concat $ map mkSignalsFromMap signals
expandArgs ::
- [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
+ [(CoreBndr, SignalNameMap)] -- A list of bindings in effect
-> [CoreExpr] -- The arguments to expand
- -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
+ -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap])
-- The resulting signal declarations,
-- component instantiations and a
-- VHDLName for each of the
splitTupleConstructorArgs [] = ([], [])
mapOutputPorts ::
- SignalNameMap AST.VHDLId -- The output portnames of the component
- -> SignalNameMap AST.VHDLId -- The output portnames and/or signals to map these to
+ SignalNameMap -- The output portnames of the component
+ -> SignalNameMap -- The output portnames and/or signals to map these to
-> [AST.AssocElem] -- The resulting output ports
-- Map the output port of a component to the output port of the containing
-- entity.
-mapOutputPorts (Signal portname) (Signal signalname) =
+mapOutputPorts (Signal portname _) (Signal signalname _) =
[(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
-- Map matching output ports in the tuple
mkIfaceSigDecs ::
AST.Mode -- The port's mode (In or Out)
- -> SignalNameMap AST.VHDLId -- The ports to generate a map for
+ -> SignalNameMap -- The ports to generate a map for
-> [AST.IfaceSigDec] -- The resulting ports
-mkIfaceSigDecs mode (Signal port_id) =
- -- TODO: Remove hardcoded type
- [AST.IfaceSigDec port_id mode vhdl_bit_ty]
+mkIfaceSigDecs mode (Signal port_id ty) =
+ [AST.IfaceSigDec port_id mode ty]
mkIfaceSigDecs mode (Tuple ports) =
concat $ map (mkIfaceSigDecs mode) ports
-- Create concurrent assignments of one map of signals to another. The maps
-- should have a similar form.
createSignalAssignments ::
- SignalNameMap AST.VHDLId -- The signals to assign to
- -> SignalNameMap AST.VHDLId -- The signals to assign
+ SignalNameMap -- The signals to assign to
+ -> SignalNameMap -- The signals to assign
-> [AST.ConcSm] -- The resulting assignments
-- A simple assignment of one signal to another (greatly complicated because
-- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Signal dst) (Signal src) =
+createSignalAssignments (Signal dst _) (Signal src _) =
[AST.CSSASm assign]
where
src_name = AST.NSimple src
createSignalAssignments dst src =
error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
-data SignalNameMap t =
- Tuple [SignalNameMap t]
- | Signal t
+data SignalNameMap =
+ Tuple [SignalNameMap]
+ | Signal AST.VHDLId AST.TypeMark -- A signal (or port) of the given (VDHL) type
deriving (Show)
-- Generate a port name map (or multiple for tuple types) in the given direction for
-- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
+getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap]
getPortNameMapForTys prefix num [] = []
getPortNameMapForTys prefix num (t:ts) =
(getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
+getPortNameMapForTy :: String -> Type -> SignalNameMap
getPortNameMapForTy name ty =
if (TyCon.isTupleTyCon tycon) then
-- Expand tuples we find
Tuple (getPortNameMapForTys name 0 args)
else -- Assume it's a type constructor application, ie simple data type
- -- TODO: Add type?
- Signal (AST.unsafeVHDLBasicId name)
+ Signal (AST.unsafeVHDLBasicId name) (vhdl_ty ty)
where
(tycon, args) = Type.splitTyConApp ty
data HWFunction = HWFunction { -- A function that is available in hardware
vhdlId :: AST.VHDLId,
- inPorts :: [SignalNameMap AST.VHDLId],
- outPort :: SignalNameMap AST.VHDLId
+ inPorts :: [SignalNameMap],
+ outPort :: SignalNameMap
--entity :: AST.EntityDec
} deriving (Show)
uniqueName name = do
count <- State.gets nameCount -- Get the funcs element from the session
State.modify (\s -> s {nameCount = count + 1})
- return $ name ++ "-" ++ (show count)
+ return $ name ++ "_" ++ (show count)
-- Shortcut
mkVHDLId :: String -> AST.VHDLId
builtin_funcs =
[
- ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
- ("hwand", HWFunction (mkVHDLId "hwand") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
- ("hwor", HWFunction (mkVHDLId "hwor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
- ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
+ ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
+ ("hwand", HWFunction (mkVHDLId "hwand") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
+ ("hwor", HWFunction (mkVHDLId "hwor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
+ ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal (mkVHDLId "i") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty))
]
vhdl_bit_ty :: AST.TypeMark
vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
+-- Translate a Haskell type to a VHDL type
+vhdl_ty :: Type -> AST.TypeMark
+vhdl_ty ty = Maybe.fromMaybe
+ (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
+ (vhdl_ty_maybe ty)
+
+-- Translate a Haskell type to a VHDL type
+vhdl_ty_maybe :: Type -> Maybe AST.TypeMark
+vhdl_ty_maybe ty =
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) ->
+ let name = TyCon.tyConName tycon in
+ -- TODO: Do something more robust than string matching
+ case getOccString name of
+ "Bit" -> Just vhdl_bit_ty
+ otherwise -> Nothing
+ otherwise -> Nothing
+
-- vim: set ts=8 sw=2 sts=2 expandtab:
projects / matthijs / master-project / cλash.git / blobdiff