import GHC.Paths ( libdir )
import DynFlags ( defaultDynFlags )
import List ( find )
+import qualified List
+import qualified Monad
+
-- The following modules come from the ForSyDe project. They are really
-- internal modules, so ForSyDe.cabal has to be modified prior to installing
-- ForSyDe to get access to these modules.
--load LoadAllTargets
--core <- GHC.compileToCoreSimplified "Adders.hs"
core <- GHC.compileToCoreSimplified "Adders.hs"
- liftIO $ printBinds (cm_binds core)
- let bind = findBind "half_adder" (cm_binds core)
- let NonRec var expr = bind
+ --liftIO $ printBinds (cm_binds core)
+ let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["full_adder", "half_adder"]
+ liftIO $ printBinds binds
-- Turn bind into VHDL
- let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
- liftIO $ putStr $ showSDoc $ ppr expr
- liftIO $ putStr "\n\n"
- liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
- return expr
+ let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 builtin_funcs)
+ liftIO $ putStr $ concat $ map (render . ForSyDe.Backend.Ppr.ppr) vhdl
+ return ()
where
-- Turns the given bind into VHDL
- mkVHDL bind = do
- -- Get the function signature
- (name, f) <- mkHWFunction bind
- -- Add it to the session
- addFunc name f
- arch <- getArchitecture bind
- return arch
+ mkVHDL binds = do
+ -- Get the function signatures
+ funcs <- mapM mkHWFunction binds
+ -- Add them to the session
+ mapM (uncurry addFunc) funcs
+ -- Create architectures for them
+ mapM getArchitecture binds
printTarget (Target (TargetFile file (Just x)) obj Nothing) =
print $ show file
printBind' (b, expr) = do
putStr $ getOccString b
- --putStr $ showSDoc $ ppr expr
+ putStr $ showSDoc $ ppr expr
putStr "\n"
-findBind :: String -> [CoreBind] -> CoreBind
-findBind lookfor =
+findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind binds lookfor =
-- This ignores Recs and compares the name of the bind with lookfor,
-- disregarding any namespaces in OccName and extra attributes in Name and
-- Var.
- Maybe.fromJust . find (\b -> case b of
+ find (\b -> case b of
Rec l -> False
NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
- )
+ ) binds
getPortMapEntry ::
- SignalNameMap String -- The port name to bind to
- -> AST.VHDLName -- The signal or port to bind to it
+ 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) signame =
- (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName signame)
+getPortMapEntry (Signal portname) (Signal signame) =
+ (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
getInstantiations ::
- [SignalNameMap String] -- The arguments that need to be applied to the
+ [SignalNameMap AST.VHDLId] -- The arguments that need to be applied to the
-- expression.
- -> SignalNameMap String -- The output ports that the expression should generate.
- -> [(CoreBndr, SignalNameMap String)]
+ -> 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])
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)
+ where
+ -- Lookup the id in our binds map
+ Signal signal_id = 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
+ let ((Var f), args) = collectArgs app
+ if isTupleConstructor f
+ then
+ expandBuildTupleExpr binds args
+ else
+ 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 AST.VHDLId)]
+ -- 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)
+ -- See expandExpr
+expandBuildTupleExpr binds args = do
+ -- Split the tuple constructor arguments into types and actual values.
+ let (_, vals) = splitTupleConstructorArgs args
+ -- Expand each of the values in the tuple
+ (signals_declss, statementss, arg_signalss, res_signals) <-
+ (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
+ 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 AST.VHDLId)]
+ -- 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)
+ -- 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 AST.VHDLId)]
+ -- 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)
+ -- 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 inports outport <- getHWFunc name
+ -- 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 (AST.unsafeVHDLBasicId name)))
+ (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 AST.VHDLId -- The port names to bind to
+ -> SignalNameMap AST.VHDLId -- The signals to bind to it
+ -> [AST.AssocElem] -- The resulting port map lines
+
+createAssocElems (Signal port_id) (Signal 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.VHDLId
+ -> [AST.SigDec]
+
+mkSignalsFromMap (Signal id) =
+ -- TODO: This uses the bit type hardcoded
+ [mkSignalFromId id vhdl_bit_ty]
+
+mkSignalsFromMap (Tuple signals) =
+ concat $ map mkSignalsFromMap signals
+
expandArgs ::
- [(CoreBndr, SignalNameMap String)] -- A list of bindings in effect
+ [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
-> [CoreExpr] -- The arguments to expand
- -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName])
+ -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])
-- 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
- Signal 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)
+ (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 ([], [], [])
where
(tys, vals) = splitTupleConstructorArgs es
+splitTupleConstructorArgs [] = ([], [])
+
mapOutputPorts ::
- SignalNameMap String -- The output portnames of the component
- -> SignalNameMap String -- The output portnames and/or signals to map these to
+ SignalNameMap AST.VHDLId -- The output portnames of the component
+ -> SignalNameMap AST.VHDLId -- 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) =
- [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
+ [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
-- Map matching output ports in the tuple
mapOutputPorts (Tuple ports) (Tuple signals) =
let name = (getOccString var)
HWFunction inports outport <- getHWFunc name
sess <- State.get
- (sigs, comps) <- getInstantiations inports outport [] expr
+ (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
+ let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
+ let outport_assigns = createSignalAssignments outport res_signal
return $ AST.ArchBody
(AST.unsafeVHDLBasicId "structural")
-- Use unsafe for now, to prevent pulling in ForSyDe error handling
(AST.NSimple (AST.unsafeVHDLBasicId name))
- (map AST.BDISD sigs)
- comps
+ (map AST.BDISD signal_decls)
+ (inport_assigns ++ outport_assigns ++ statements)
+
+-- 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
+ -> [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) =
+ [AST.CSSASm assign]
+ where
+ src_name = AST.NSimple src
+ src_expr = AST.PrimName src_name
+ src_wform = AST.Wform [AST.WformElem src_expr Nothing]
+ dst_name = (AST.NSimple dst)
+ assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+
+createSignalAssignments (Tuple dsts) (Tuple srcs) =
+ concat $ zipWith createSignalAssignments dsts srcs
+
+createSignalAssignments dst src =
+ error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
data SignalNameMap t =
Tuple [SignalNameMap t]
-- Generate a port name map (or multiple for tuple types) in the given direction for
-- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap String]
+getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
getPortNameMapForTys prefix num [] = []
getPortNameMapForTys prefix num (t:ts) =
(getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
-getPortNameMapForTy :: String -> Type -> SignalNameMap String
+getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
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 name
+ Signal (AST.unsafeVHDLBasicId name)
where
(tycon, args) = Type.splitTyConApp ty
data HWFunction = HWFunction { -- A function that is available in hardware
- inPorts :: [SignalNameMap String],
- outPort :: SignalNameMap String
+ inPorts :: [SignalNameMap AST.VHDLId],
+ outPort :: SignalNameMap AST.VHDLId
--entity :: AST.EntityDec
} deriving (Show)
count <- State.gets nameCount -- Get the funcs element from the session
State.modify (\s -> s {nameCount = count + 1})
return $ name ++ "-" ++ (show count)
-
+
+-- Shortcut
+mkVHDLId :: String -> AST.VHDLId
+mkVHDLId = AST.unsafeVHDLBasicId
+
builtin_funcs =
[
- ("hwxor", HWFunction [Signal "a", Signal "b"] (Signal "o")),
- ("hwand", HWFunction [Signal "a", Signal "b"] (Signal "o"))
+ ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
+ ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
+ ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
+ ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
]
+vhdl_bit_ty :: AST.TypeMark
+vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
+
-- vim: set ts=8 sw=2 sts=2 expandtab:
projects / matthijs / master-project / cλash.git / blobdiff