2 -- Functions to generate VHDL from FlatFunctions
6 import Data.Traversable
7 import qualified Data.Foldable as Foldable
12 import qualified TyCon
13 import Outputable ( showSDoc, ppr )
15 import qualified ForSyDe.Backend.VHDL.AST as AST
19 import TranslatorTypes
21 -- | Create an entity for a given function
23 HsFunction -- | The function signature
24 -> FuncData -- | The function data collected so far
25 -> FuncData -- | The modified function data
27 createEntity hsfunc fdata =
28 let func = flatFunc fdata in
30 -- Skip (builtin) functions without a FlatFunction
32 -- Create an entity for all other functions
36 sigs = flat_sigs flatfunc
37 args = flat_args flatfunc
38 res = flat_res flatfunc
39 args' = map (fmap (mkMap sigs)) args
40 res' = fmap (mkMap sigs) res
41 ent_decl' = createEntityAST hsfunc args' res'
42 entity' = Entity args' res' (Just ent_decl')
44 fdata { funcEntity = Just entity' }
46 mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
48 (mkVHDLId nm, vhdl_ty ty)
50 info = Maybe.fromMaybe
51 (error $ "Signal not found in the name map? This should not happen!")
54 (error $ "Signal not named? This should not happen!")
58 -- | Create the VHDL AST for an entity
60 HsFunction -- | The signature of the function we're working with
61 -> [VHDLSignalMap] -- | The entity's arguments
62 -> VHDLSignalMap -- | The entity's result
63 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
65 createEntityAST hsfunc args res =
66 AST.EntityDec vhdl_id ports
68 vhdl_id = mkEntityId hsfunc
69 ports = concatMap (mapToPorts AST.In) args
70 ++ mapToPorts AST.Out res
71 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
73 map (mkIfaceSigDec mode) (Foldable.toList m)
75 -- | Create a port declaration
77 AST.Mode -- | The mode for the port (In / Out)
78 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
79 -> AST.IfaceSigDec -- | The resulting port declaration
81 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
83 -- | Generate a VHDL entity name for the given hsfunc
85 -- TODO: This doesn't work for functions with multiple signatures!
86 mkVHDLId $ hsFuncName hsfunc
88 -- | Create an architecture for a given function
90 HsFunction -- | The function signature
91 -> FuncData -- | The function data collected so far
92 -> FuncData -- | The modified function data
94 createArchitecture hsfunc fdata =
95 let func = flatFunc fdata in
97 -- Skip (builtin) functions without a FlatFunction
99 -- Create an architecture for all other functions
102 sigs = flat_sigs flatfunc
103 args = flat_args flatfunc
104 res = flat_res flatfunc
105 apps = flat_apps flatfunc
106 entity_id = Maybe.fromMaybe
107 (error $ "Building architecture without an entity? This should not happen!")
109 -- Create signal declarations for all signals that are not in args and
111 sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
112 -- Create component instantiations for all function applications
113 insts = map (AST.CSISm . mkCompInsSm) apps
114 arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) insts
116 fdata { funcArch = Just arch }
118 mkSigDec :: SignalInfo -> AST.SigDec
120 AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing
122 name = Maybe.fromMaybe
123 (error $ "Unnamed signal? This should not happen!")
127 -- | Transforms a flat function application to a VHDL component instantiation.
129 FApp UnnamedSignal -- | The application to look at.
130 -> AST.CompInsSm -- | The corresponding VHDL component instantiation.
133 AST.CompInsSm label (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
135 entity_id = mkVHDLId "foo"
136 label = mkVHDLId "app"
139 -- | Extracts the generated entity id from the given funcdata
140 getEntityId :: FuncData -> Maybe AST.VHDLId
142 case funcEntity fdata of
144 Just e -> case ent_decl e of
146 Just (AST.EntityDec id _) -> Just id
149 (HsFunction, FuncData) -- | A function from the session
150 -> [AST.LibraryUnit] -- | The library units it generates
152 getLibraryUnits (hsfunc, fdata) =
153 case funcEntity fdata of
155 Just ent -> case ent_decl ent of
157 Just decl -> [AST.LUEntity decl]
159 case funcArch fdata of
161 Just arch -> [AST.LUArch arch]
163 -- | The VHDL Bit type
164 bit_ty :: AST.TypeMark
165 bit_ty = AST.unsafeVHDLBasicId "Bit"
167 -- Translate a Haskell type to a VHDL type
168 vhdl_ty :: Type.Type -> AST.TypeMark
169 vhdl_ty ty = Maybe.fromMaybe
170 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
173 -- Translate a Haskell type to a VHDL type
174 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
176 case Type.splitTyConApp_maybe ty of
177 Just (tycon, args) ->
178 let name = TyCon.tyConName tycon in
179 -- TODO: Do something more robust than string matching
180 case Name.getOccString name of
186 mkVHDLId :: String -> AST.VHDLId
187 mkVHDLId = AST.unsafeVHDLBasicId