X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=87569695e69b730a0d2fb192a250a22336d77e3d;hb=765f2b02d5a81e0920a26b90c72b95d7ac6e68a2;hp=713698c70fea58e8447dfbf291f8634ffb8de77d;hpb=6bf116914c36c98e7f76ec9c20f993cd847a7ee8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Translator.hs b/Translator.hs index 713698c..8756969 100644 --- a/Translator.hs +++ b/Translator.hs @@ -91,16 +91,15 @@ findBind lookfor = NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var) ) +getPortMapEntry :: + PortNameMap -- The port name to bind to + -> AST.VHDLName -- 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 binds (Port portname) (Var id) = - (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName (AST.NSimple (AST.unsafeVHDLBasicId signalname))) - where - Port signalname = Maybe.fromMaybe - (error $ "Argument " ++ getOccString id ++ "is unknown") - (lookup id binds) - -getPortMapEntry binds _ a = error $ "Unsupported argument: " ++ (showSDoc $ ppr a) +getPortMapEntry (Port portname) signame = + (Just (AST.unsafeVHDLBasicId portname)) AST.:=>: (AST.ADName signame) getInstantiations :: [PortNameMap] -- The arguments that need to be applied to the @@ -108,7 +107,7 @@ getInstantiations :: -> 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 - -> VHDLState [AST.ConcSm] -- The resulting VHDL code + -> 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) = @@ -117,21 +116,28 @@ getInstantiations (a:as) outs binds (Lam b 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 - getInstantiations args outs binds' expr + 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" - where - binds' = (zip bind_vars tuple_ports) ++ binds - (altcon, bind_vars, expr) = res - -- Find the portnamemaps for each of the tuple's elements - Tuple tuple_ports = Maybe.fromMaybe - (error $ "Case expression uses unknown scrutinee " ++ getOccString v) - (lookup v binds) -- An application is an instantiation of a component getInstantiations args outs binds app@(App expr arg) = do @@ -139,26 +145,72 @@ getInstantiations args outs binds app@(App expr arg) = do name = getOccString f if isTupleConstructor f then do + -- Get the signals we should bind our results to let Tuple outports = outs - (tys, vals) = splitTupleConstructorArgs fargs - insts <- sequence $ zipWith + -- 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 - return $ concat insts + -- 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 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 "app") + (AST.unsafeVHDLBasicId appname) (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name))) - (AST.PMapAspect ports) - ports = - zipWith (getPortMapEntry binds) inports fargs - ++ mapOutputPorts outport outs - return [AST.CSISm comp] + (AST.PMapAspect (inmaps ++ outmaps)) + return (sigs, (AST.CSISm comp) : comps) getInstantiations args outs binds expr = error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr) +expandArgs :: + [(CoreBndr, PortNameMap)] -- A list of bindings in effect + -> [CoreExpr] -- The arguments to expand + -> VHDLState ([AST.SigDec], [AST.ConcSm], [AST.VHDLName]) + -- 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 + Port 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) + +expandArgs _ [] = return ([], [], []) + -- Is the given name a (binary) tuple constructor isTupleConstructor :: Var.Var -> Bool isTupleConstructor var = @@ -205,13 +257,13 @@ getArchitecture (NonRec var expr) = do let name = (getOccString var) HWFunction inports outport <- getHWFunc name sess <- State.get - insts <- getInstantiations inports outport [] expr + (sigs, comps) <- getInstantiations inports outport [] expr return $ AST.ArchBody (AST.unsafeVHDLBasicId "structural") -- Use unsafe for now, to prevent pulling in ForSyDe error handling (AST.NSimple (AST.unsafeVHDLBasicId name)) - [] - (insts) + (map AST.BDISD sigs) + comps data PortNameMap = Tuple [PortNameMap]