-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)