-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"
- where
- ((Var f), args) = collectArgs app
-
-getInstantiations args binds expr = showSDoc $ ppr $ expr
-
-getArchitecture (NonRec var expr) =
- "architecture structural of " ++ name ++ " is\n"
- ++ "begin\n"
- ++ getInstantiations (Args [Tuple [Port "portin0", Port "portin1"]]) [] expr
- ++ "end structural\n"
- where
- name = (getOccString var)
- ty = CoreUtils.exprType expr
+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
+ insts <- sequence $ zipWith
+ (\outs' expr' -> getInstantiations args outs' binds expr')
+ outports vals
+ -- And join all the component instantiations together
+ return $ concat insts
+ 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"
+ -- Bind each of the input ports to an argument
+ let inmaps = zipWith (getPortMapEntry binds) inports fargs
+ -- 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 (AST.unsafeVHDLBasicId name)))
+ (AST.PMapAspect (inmaps ++ outmaps))
+ return [AST.CSISm comp]
+
+getInstantiations 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
+ (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)))]
+
+-- Map matching output ports in the tuple
+mapOutputPorts (Tuple ports) (Tuple signals) =
+ concat (zipWith mapOutputPorts ports signals)
+
+getArchitecture ::
+ CoreBind -- The binder to expand into an architecture
+ -> VHDLState AST.ArchBody -- The resulting architecture
+
+getArchitecture (Rec _) = error "Recursive binders not supported"
+
+getArchitecture (NonRec var expr) = do
+ let name = (getOccString var)
+ HWFunction inports outport <- getHWFunc name
+ sess <- State.get
+ insts <- 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)