-- Accepts a port name and an argument to map to it.
-- Returns the appropriate line for in the port map
-getPortMapEntry (Signal portname _) (Signal signame _) =
+getPortMapEntry (Single (portname, _)) (Single (signame, _)) =
(Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
expandExpr ::
[(CoreBndr, SignalNameMap)]
res_signal')
expandExpr binds (Var id) =
- return ([], [], [], Signal signal_id ty)
+ return ([], [], [], Single (signal_id, ty))
where
-- Lookup the id in our binds map
- Signal signal_id ty = Maybe.fromMaybe
+ Single (signal_id, ty) = Maybe.fromMaybe
(error $ "Argument " ++ getOccString id ++ "is unknown")
(lookup id binds)
res_signals')
expandExpr binds app@(App _ _) = do
- let ((Var f), args) = collectArgs app
- if isTupleConstructor f
- then
- expandBuildTupleExpr binds args
- else
+ -- Is this a data constructor application?
+ case CoreUtils.exprIsConApp_maybe app of
+ -- Is this a tuple construction?
+ Just (dc, args) -> if DataCon.isTupleCon dc
+ then
+ expandBuildTupleExpr binds (dataConAppArgs dc args)
+ else
+ error "Data constructors other than tuples not supported"
+ otherise ->
+ -- Normal function application, should map to a component instantiation
+ let ((Var f), args) = collectArgs app in
expandApplicationExpr binds (CoreUtils.exprType app) f args
expandExpr binds expr@(Case (Var v) b _ alts) =
-- See expandExpr
expandBuildTupleExpr binds args = do
-- Split the tuple constructor arguments into types and actual values.
- let (_, vals) = splitTupleConstructorArgs args
-- Expand each of the values in the tuple
(signals_declss, statementss, arg_signalss, res_signals) <-
- (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
+ (Monad.liftM List.unzip4) $ mapM (expandExpr binds) args
if any (not . null) arg_signalss
then error "Putting high order functions in tuples not supported"
else
-> SignalNameMap -- The signals to bind to it
-> [AST.AssocElem] -- The resulting port map lines
-createAssocElems (Signal port_id _) (Signal signal_id _) =
+createAssocElems (Single (port_id, _)) (Single (signal_id, _)) =
[(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
createAssocElems (Tuple ports) (Tuple signals) =
SignalNameMap
-> [AST.SigDec]
-mkSignalsFromMap (Signal id ty) =
+mkSignalsFromMap (Single (id, ty)) =
[mkSignalFromId id ty]
mkSignalsFromMap (Tuple signals) =
expandArgs _ [] = return ([], [], [])
--- 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)
+-- Extract the arguments from a data constructor application (that is, the
+-- normal args, leaving out the type args).
+dataConAppArgs :: DataCon -> [CoreExpr] -> [CoreExpr]
+dataConAppArgs dc args =
+ drop tycount args
where
- (tys, vals) = splitTupleConstructorArgs es
-
-splitTupleConstructorArgs [] = ([], [])
+ tycount = length $ DataCon.dataConAllTyVars dc
mapOutputPorts ::
SignalNameMap -- The output portnames of the component
-- Map the output port of a component to the output port of the containing
-- entity.
-mapOutputPorts (Signal portname _) (Signal signalname _) =
+mapOutputPorts (Single (portname, _)) (Single (signalname, _)) =
[(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
-- Map matching output ports in the tuple
-> SignalNameMap -- The ports to generate a map for
-> [AST.IfaceSigDec] -- The resulting ports
-mkIfaceSigDecs mode (Signal port_id ty) =
+mkIfaceSigDecs mode (Single (port_id, ty)) =
[AST.IfaceSigDec port_id mode ty]
mkIfaceSigDecs mode (Tuple ports) =
-- A simple assignment of one signal to another (greatly complicated because
-- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Signal dst _) (Signal src _) =
+createSignalAssignments (Single (dst, _)) (Single (src, _)) =
[AST.CSSASm assign]
where
src_name = AST.NSimple src
createSignalAssignments dst src =
error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++ show src
-data SignalNameMap =
- Tuple [SignalNameMap]
- | Signal AST.VHDLId AST.TypeMark -- A signal (or port) of the given (VDHL) type
+type SignalNameMap = HsValueMap (AST.VHDLId, AST.TypeMark)
+
+-- | A datatype that maps each of the single values in a haskell structure to
+-- a mapto. The map has the same structure as the haskell type mapped, ie
+-- nested tuples etc.
+data HsValueMap mapto =
+ Tuple [HsValueMap mapto]
+ | Single mapto
deriving (Show)
-- Generate a port name map (or multiple for tuple types) in the given direction for
-- Expand tuples we find
Tuple (getPortNameMapForTys name 0 args)
else -- Assume it's a type constructor application, ie simple data type
- Signal (AST.unsafeVHDLBasicId name) (vhdl_ty ty)
+ Single ((AST.unsafeVHDLBasicId name), (vhdl_ty ty))
where
(tycon, args) = Type.splitTyConApp ty
builtin_funcs =
[
- ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
- ("hwand", HWFunction (mkVHDLId "hwand") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
- ("hwor", HWFunction (mkVHDLId "hwor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
- ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal (mkVHDLId "i") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty))
+ ("hwxor", HWFunction (mkVHDLId "hwxor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+ ("hwand", HWFunction (mkVHDLId "hwand") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+ ("hwor", HWFunction (mkVHDLId "hwor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+ ("hwnot", HWFunction (mkVHDLId "hwnot") [Single (mkVHDLId "i", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty)))
]
vhdl_bit_ty :: AST.TypeMark
projects / matthijs / master-project / cλash.git / blobdiff