X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=d76ff15dc12f132483ac8244857809d01482e645;hb=1e1972884f324bbe6d046e2b52b9f9ea41014889;hp=c96bebce5e5cd1eca842ff4645af848663a42000;hpb=358a33adc0f4328d1908938952d2edef85e75546;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index c96bebc..d76ff15 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -8,6 +8,7 @@ import qualified TyCon
 import qualified DataCon
 import qualified Maybe
 import qualified Module
+import qualified Control.Monad.State as State
 import Name
 import Data.Generics
 import NameEnv ( lookupNameEnv )
@@ -42,13 +43,19 @@ main =
 					liftIO $ printBinds (cm_binds core)
 					let bind = findBind "half_adder" (cm_binds core)
 					let NonRec var expr = bind
-					let sess = VHDLSession 0 builtin_funcs
-					let (sess', name, f) = mkHWFunction sess bind
-					let sess = addFunc sess' name f
+					-- Add the HWFunction from the bind to the session
+					let sess = State.execState (addF bind) (VHDLSession 0 builtin_funcs)
 					liftIO $ putStr $ showSDoc $ ppr expr
 					liftIO $ putStr "\n\n"
 					liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ getArchitecture sess bind
 					return expr
+	where
+		-- Turns the given bind into VHDL
+		addF bind = do
+			-- Get the function signature
+			(name, f) <- mkHWFunction bind
+			-- Add it to the session
+			addFunc name f
 
 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
 	print $ show file
@@ -95,17 +102,16 @@ getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr
 
 getInstantiations ::
 	VHDLSession
-	-> PortNameMap                  -- The arguments that need to be applied to the
-															 -- expression. Should always be the Args
-															 -- constructor.
+	-> [PortNameMap]             -- The arguments that need to be applied to the
+															 -- expression.
 	-> 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
 	-> [AST.ConcSm]              -- The resulting VHDL code
 
 -- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations sess (Args (a:as)) outs binds (Lam b expr) =
-	getInstantiations sess (Args as) outs ((b, a):binds) expr
+getInstantiations sess (a:as) outs binds (Lam b expr) =
+	getInstantiations sess 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
@@ -148,7 +154,7 @@ getInstantiations sess args outs binds app@(App expr arg) =
 		hwfunc = Maybe.fromMaybe
 			(error $ "Function " ++ compname ++ "is unknown")
 			(lookup compname (funcs sess))
-		HWFunction (Args inports) outport = hwfunc
+		HWFunction inports outport = hwfunc
 		ports = 
 			zipWith (getPortMapEntry binds) inports fargs
 		  ++ mapOutputPorts outport outs
@@ -205,19 +211,18 @@ getArchitecture sess (NonRec var expr) =
 		-- Use unsafe for now, to prevent pulling in ForSyDe error handling
 		(AST.NSimple (AST.unsafeVHDLBasicId name))
 		[]
-		(getInstantiations sess (Args inports) outport [] expr)
+		(getInstantiations sess inports outport [] expr)
 	where
 		name = (getOccString var)
 		hwfunc = Maybe.fromMaybe
 			(error $ "Function " ++ name ++ "is unknown? This should not happen!")
 			(lookup name (funcs sess))
-		HWFunction (Args inports) outport = hwfunc
+		HWFunction inports outport = hwfunc
 
 data PortNameMap =
-	Args [PortNameMap] -- Each of the submaps represent an argument to the
-	                   -- function. Should only occur at top level.
-	| Tuple [PortNameMap]
+	Tuple [PortNameMap]
 	| Port  String
+  deriving (Show)
 
 -- Generate a port name map (or multiple for tuple types) in the given direction for
 -- each type given.
@@ -238,20 +243,19 @@ getPortNameMapForTy name ty =
 		(tycon, args) = Type.splitTyConApp ty 
 
 data HWFunction = HWFunction { -- A function that is available in hardware
-	inPorts   :: PortNameMap,
-	outPorts  :: PortNameMap
+	inPorts   :: [PortNameMap],
+	outPort   :: PortNameMap
 	--entity    :: AST.EntityDec
-}
+} deriving (Show)
 
 -- Turns a CoreExpr describing a function into a description of its input and
 -- output ports.
 mkHWFunction ::
-	VHDLSession
-	-> CoreBind                                -- The core binder to generate the interface for
-	-> (VHDLSession, String, HWFunction)       -- The name of the function and its interface
+	CoreBind                                   -- The core binder to generate the interface for
+	-> VHDLState (String, HWFunction)          -- The name of the function and its interface
 
-mkHWFunction sess (NonRec var expr) =
-	(sess, name, HWFunction (Args inports) outport)
+mkHWFunction (NonRec var expr) =
+		return (name, HWFunction inports outport)
 	where
 		name = (getOccString var)
 		ty = CoreUtils.exprType expr
@@ -264,21 +268,24 @@ mkHWFunction sess (NonRec var expr) =
 			ps     -> getPortNameMapForTys "portin" 0 ps
 		outport = getPortNameMapForTy "portout" res
 
-mkHWFunction sess (Rec _) =
+mkHWFunction (Rec _) =
 	error "Recursive binders not supported"
 
 data VHDLSession = VHDLSession {
 	nameCount :: Int,                      -- A counter that can be used to generate unique names
 	funcs     :: [(String, HWFunction)]    -- All functions available, indexed by name
-}
+} deriving (Show)
+
+type VHDLState = State.State VHDLSession
 
 -- Add the function to the session
-addFunc :: VHDLSession -> String -> HWFunction -> VHDLSession
-addFunc sess name f =
-	sess {funcs = (name, f) : (funcs sess) }
+addFunc :: String -> HWFunction -> VHDLState ()
+addFunc name f = do
+	fs <- State.gets funcs -- Get the funcs element form the session
+	State.modify (\x -> x {funcs = (name, f) : fs }) -- Prepend name and f
 
 builtin_funcs = 
 	[ 
-		("hwxor", HWFunction (Args [Port "a", Port "b"]) (Port "o")),
-		("hwand", HWFunction (Args [Port "a", Port "b"]) (Port "o"))
+		("hwxor", HWFunction [Port "a", Port "b"] (Port "o")),
+		("hwand", HWFunction [Port "a", Port "b"] (Port "o"))
 	]