X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=18c45d770589e62d4a19bbcebbda82bed5c5ade3;hb=3e99712591aef1650da0fb0de95bfb9eb122d55a;hp=64cdb5199a9aa5b5e69b9008b12d6b63a704105d;hpb=d49dfd213e2cd384bceb38dc70eb122711d4f996;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 64cdb51..18c45d7 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -124,21 +124,22 @@ 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)) binds (Lam b expr) =
-	getInstantiations (Args as) ((b, a):binds) expr
+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 binds (Case (Var v) b _ [res]) =
+getInstantiations args outs binds (Case (Var v) b _ [res]) =
 	case altcon of
 		DataAlt datacon ->
 			if (DataCon.isTupleCon datacon) then
-				getInstantiations args binds' expr
+				getInstantiations args outs binds' expr
 			else
 				error "Data constructors other than tuples not supported"
 		otherwise ->
@@ -152,28 +153,65 @@ getInstantiations args binds (Case (Var v) b _ [res]) =
 			(lookup v binds)
 
 -- An application is an instantiation of a component
-getInstantiations args binds app@(App expr arg) =
+getInstantiations args outs 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"
+	-- Map input ports of f
 	++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
+	-- Map output ports of f
+	++ mapOutputPorts (Port "portout") outs
 	++ ");\n"
 	where
 		((Var f), args) = collectArgs app
 
-getInstantiations args binds expr = showSDoc $ ppr $ expr
+getInstantiations args outs binds expr = showSDoc $ ppr $ expr
+
+-- Map the output port of a component to the output port of the containing
+-- entity.
+mapOutputPorts (Port port) (Port signal) =
+	"\t" ++ port ++ " => " ++ signal ++ "\n"
+
+-- 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
+	++ getInstantiations (Args inportnames) outport [] expr
 	++ "end structural\n"
 	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