-- 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
-- Returns the appropriate line for in the port map
getPortMapEntry (Signal portname _) (Signal signame _) =
(Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
-
-getInstantiations ::
- [SignalNameMap] -- The arguments that need to be applied to the
- -- expression.
- -> 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])
- -- 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)]
-- A list of bindings in effect
-- 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
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
-- Expand tuples we find
Tuple (getPortNameMapForTys name 0 args)
else -- Assume it's a type constructor application, ie simple data type
- -- TODO: Don't hardcode the type here
- Signal (AST.unsafeVHDLBasicId name) vhdl_bit_ty
+ Signal (AST.unsafeVHDLBasicId name) (vhdl_ty ty)
where
(tycon, args) = Type.splitTyConApp ty
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
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