import qualified TyCon
import qualified DataCon
import qualified Maybe
+import qualified Module
import Name
import Data.Generics
import NameEnv ( lookupNameEnv )
import GHC.Paths ( libdir )
import DynFlags ( defaultDynFlags )
import List ( find )
+-- 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.
+import qualified ForSyDe.Backend.VHDL.AST as AST
+import qualified ForSyDe.Backend.VHDL.Ppr
+import qualified ForSyDe.Backend.Ppr
+-- This is needed for rendering the pretty printed VHDL
+import Text.PrettyPrint.HughesPJ (render)
main =
do
--core <- GHC.compileToCoreSimplified "Adders.hs"
core <- GHC.compileToCoreSimplified "Adders.hs"
liftIO $ printBinds (cm_binds core)
- let bind = findBind "no_carry_adder" (cm_binds core)
+ let bind = findBind "half_adder" (cm_binds core)
let NonRec var expr = bind
+ let sess = VHDLSession 0 builtin_funcs
liftIO $ putStr $ showSDoc $ ppr expr
liftIO $ putStr "\n\n"
- liftIO $ putStr $ getEntity bind
- liftIO $ putStr $ getArchitecture bind
+ liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
return expr
printTarget (Target (TargetFile file (Just x)) obj Nothing) =
NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
)
--- Generate a port (or multiple for tuple types) in the given direction for
--- each type given.
-getPortsForTys :: String -> String -> Int -> [Type] -> String
-getPortsForTys dir prefix num [] = ""
-getPortsForTys dir prefix num (t:ts) =
- (getPortsForTy dir (prefix ++ show num) t) ++ getPortsForTys dir prefix (num + 1) ts
-
-getPortsForFunTy ty =
- -- All of a function's arguments become IN ports, the result becomes on
- -- (or more) OUT ports.
- -- Drop the first ;\n
- drop 2 (getPortsForTys "in" "portin" 0 args) ++ (getPortsForTy "out" "portout" res) ++ "\n"
- where
- (args, res) = Type.splitFunTys ty
-
-getPortsForTy :: String -> String -> Type -> String
-getPortsForTy dir name ty =
- if (TyCon.isTupleTyCon tycon) then
- -- Expand tuples we find
- getPortsForTys dir name 0 args
- else -- Assume it's a type constructor application, ie simple data type
- let
- vhdlTy = showSDoc $ ppr $ TyCon.tyConName tycon;
- in
- ";\n\t" ++ name ++ " : " ++ dir ++ " " ++ vhdlTy
- where
- (tycon, args) = Type.splitTyConApp ty
-
-getEntity (NonRec var expr) =
- "entity " ++ name ++ " is\n"
- ++ "port (\n"
- ++ getPortsForFunTy ty
- ++ ");\n"
- ++ "end " ++ name ++ ";\n\n"
- where
- name = (getOccString var)
- ty = CoreUtils.exprType expr
-
-- Accepts a port name and an argument to map to it.
-- Returns the appropriate line for in the port map
getPortMapEntry binds portname (Var id) =
- "\t" ++ portname ++ " => " ++ signalname ++ "\n"
+ (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))
where
Port signalname = Maybe.fromMaybe
(error $ "Argument " ++ getOccString id ++ "is unknown")
getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a)
getInstantiations ::
- PortNameMap -- The arguments that need to be applied to the
+ VHDLSession
+ -> 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
+ -> [AST.ConcSm] -- The resulting VHDL code
-- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (Args (a:as)) binds (Lam b expr) =
- getInstantiations (Args as) ((b, a):binds) expr
+getInstantiations sess (Args (a:as)) outs binds (Lam b expr) =
+ getInstantiations sess (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 binds (Case (Var v) b _ [res]) =
+getInstantiations sess args outs binds (Case (Var v) b _ [res]) =
case altcon of
DataAlt datacon ->
if (DataCon.isTupleCon datacon) then
- getInstantiations args binds' expr
+ getInstantiations sess args outs binds' expr
else
error "Data constructors other than tuples not supported"
otherwise ->
(lookup v binds)
-- An application is an instantiation of a component
-getInstantiations args binds app@(App expr arg) =
- --indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
- "app : " ++ (getOccString f) ++ "\n"
- ++ "port map (\n"
- ++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
- ++ ");\n"
+getInstantiations sess 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 sess args outs' binds expr')
+ outports vals
+ else
+ [AST.CSISm comp]
+ where
+ ((Var f), fargs) = collectArgs app
+ comp = AST.CompInsSm
+ (AST.unsafeVHDLBasicId "app")
+ (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId compname)))
+ (AST.PMapAspect ports)
+ compname = getOccString f
+ hwfunc = Maybe.fromMaybe
+ (error $ "Function " ++ compname ++ "is unknown")
+ (lookup compname (funcs sess))
+ HWFunction inports outports = hwfunc
+ ports =
+ zipWith (getPortMapEntry binds) ["portin0", "portin1"] fargs
+ ++ mapOutputPorts outports outs
+
+getInstantiations sess 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
- ((Var f), args) = collectArgs app
+ (tys, vals) = splitTupleConstructorArgs es
+
+mapOutputPorts ::
+ PortNameMap -- The output portnames of the component
+ -> PortNameMap -- 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 (Port portname) (Port signalname) =
+ [(Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname)))]
-getInstantiations args binds expr = showSDoc $ ppr $ expr
+-- Map matching output ports in the tuple
+mapOutputPorts (Tuple ports) (Tuple signals) =
+ concat (zipWith mapOutputPorts ports signals)
-getArchitecture (NonRec var expr) =
- "architecture structural of " ++ name ++ " is\n"
- ++ "begin\n"
- ++ getInstantiations (Args [Tuple [Port "portin0", Port "portin1"]]) [] expr
- ++ "end structural\n"
+getArchitecture ::
+ VHDLSession
+ -> CoreBind -- The binder to expand into an architecture
+ -> AST.ArchBody -- The resulting architecture
+
+getArchitecture sess (Rec _) = error "Recursive binders not supported"
+
+getArchitecture sess (NonRec var expr) =
+ AST.ArchBody
+ (AST.unsafeVHDLBasicId "structural")
+ -- Use unsafe for now, to prevent pulling in ForSyDe error handling
+ (AST.NSimple (AST.unsafeVHDLBasicId name))
+ []
+ (getInstantiations sess (Args inportnames) outport [] expr)
where
name = (getOccString var)
ty = CoreUtils.exprType expr
+ (fargs, res) = Type.splitFunTys ty
+ --state = if length fargs == 1 then () else (last fargs)
+ ports = if length fargs == 1 then fargs else (init fargs)
+ inportnames = case ports of
+ [port] -> [getPortNameMapForTy "portin" port]
+ ps -> getPortNameMapForTys "portin" 0 ps
+ outport = getPortNameMapForTy "portout" res
data PortNameMap =
Args [PortNameMap] -- Each of the submaps represent an argument to the
-- function. Should only occur at top level.
| Tuple [PortNameMap]
| Port String
+
+-- Generate a port name map (or multiple for tuple types) in the given direction for
+-- each type given.
+getPortNameMapForTys :: String -> Int -> [Type] -> [PortNameMap]
+getPortNameMapForTys prefix num [] = []
+getPortNameMapForTys prefix num (t:ts) =
+ (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
+
+getPortNameMapForTy :: String -> Type -> PortNameMap
+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?
+ Port name
+ where
+ (tycon, args) = Type.splitTyConApp ty
+
+data HWFunction = HWFunction { -- A function that is available in hardware
+ inPorts :: PortNameMap,
+ outPorts :: PortNameMap
+ --entity :: AST.EntityDec
+}
+
+data VHDLSession = VHDLSession {
+ nameCount :: Int, -- A counter that can be used to generate unique names
+ funcs :: [(String, HWFunction)] -- All functions available, indexed by name
+}
+
+builtin_funcs =
+ [
+ ("hwxor", HWFunction (Args [Port "a", Port "b"]) (Port "o")),
+ ("hwand", HWFunction (Args [Port "a", Port "b"]) (Port "o"))
+ ]
projects / matthijs / master-project / cλash.git / blobdiff