2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
11 import qualified TyCon
12 import Outputable ( showSDoc, ppr )
14 import qualified ForSyDe.Backend.VHDL.AST as AST
18 import TranslatorTypes
20 -- | Create an entity for a given function
22 HsFunction -- | The function signature
23 -> FuncData -- | The function data collected so far
26 createEntity hsfunc fdata =
27 let func = flatFunc fdata in
29 -- Skip (builtin) functions without a FlatFunction
30 Nothing -> do return ()
31 -- Create an entity for all other functions
35 sigs = flat_sigs flatfunc
36 args = flat_args flatfunc
37 res = flat_res flatfunc
38 args' = map (fmap (mkMap sigs)) args
39 res' = fmap (mkMap sigs) res
40 ent_decl' = createEntityAST hsfunc args' res'
41 entity' = Entity args' res' (Just ent_decl')
43 setEntity hsfunc entity'
45 mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
47 (mkVHDLId nm, vhdl_ty ty)
49 info = Maybe.fromMaybe
50 (error $ "Signal not found in the name map? This should not happen!")
53 (error $ "Signal not named? This should not happen!")
57 -- | Create the VHDL AST for an entity
59 HsFunction -- | The signature of the function we're working with
60 -> [VHDLSignalMap] -- | The entity's arguments
61 -> VHDLSignalMap -- | The entity's result
62 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
64 createEntityAST hsfunc args res =
65 AST.EntityDec vhdl_id ports
67 vhdl_id = mkEntityId hsfunc
68 ports = concatMap (mapToPorts AST.In) args
69 ++ mapToPorts AST.Out res
70 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
72 map (mkIfaceSigDec mode) (Foldable.toList m)
74 -- | Create a port declaration
76 AST.Mode -- | The mode for the port (In / Out)
77 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
78 -> AST.IfaceSigDec -- | The resulting port declaration
80 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
82 -- | Generate a VHDL entity name for the given hsfunc
84 -- TODO: This doesn't work for functions with multiple signatures!
85 mkVHDLId $ hsFuncName hsfunc
87 -- | Create an architecture for a given function
89 HsFunction -- | The function signature
90 -> FuncData -- | The function data collected so far
93 createArchitecture hsfunc fdata =
94 let func = flatFunc fdata in
96 -- Skip (builtin) functions without a FlatFunction
97 Nothing -> do return ()
98 -- Create an architecture for all other functions
100 let sigs = flat_sigs flatfunc
101 let args = flat_args flatfunc
102 let res = flat_res flatfunc
103 let apps = flat_apps flatfunc
104 let entity_id = Maybe.fromMaybe
105 (error $ "Building architecture without an entity? This should not happen!")
107 -- Create signal declarations for all signals that are not in args and
109 let sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
110 -- Create component instantiations for all function applications
111 insts <- mapM mkCompInsSm apps
112 let insts' = map AST.CSISm insts
113 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) insts'
114 setArchitecture hsfunc arch
116 mkSigDec :: SignalInfo -> AST.SigDec
118 AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing
120 name = Maybe.fromMaybe
121 (error $ "Unnamed signal? This should not happen!")
125 -- | Transforms a flat function application to a VHDL component instantiation.
127 FApp UnnamedSignal -- | The application to look at.
128 -> VHDLState AST.CompInsSm -- | The corresponding VHDL component instantiation.
131 return $ AST.CompInsSm label (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
133 entity_id = mkVHDLId "foo"
134 label = mkVHDLId "app"
137 -- | Extracts the generated entity id from the given funcdata
138 getEntityId :: FuncData -> Maybe AST.VHDLId
140 case funcEntity fdata of
142 Just e -> case ent_decl e of
144 Just (AST.EntityDec id _) -> Just id
147 (HsFunction, FuncData) -- | A function from the session
148 -> [AST.LibraryUnit] -- | The library units it generates
150 getLibraryUnits (hsfunc, fdata) =
151 case funcEntity fdata of
153 Just ent -> case ent_decl ent of
155 Just decl -> [AST.LUEntity decl]
157 case funcArch fdata of
159 Just arch -> [AST.LUArch arch]
161 -- | The VHDL Bit type
162 bit_ty :: AST.TypeMark
163 bit_ty = AST.unsafeVHDLBasicId "Bit"
165 -- Translate a Haskell type to a VHDL type
166 vhdl_ty :: Type.Type -> AST.TypeMark
167 vhdl_ty ty = Maybe.fromMaybe
168 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
171 -- Translate a Haskell type to a VHDL type
172 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
174 case Type.splitTyConApp_maybe ty of
175 Just (tycon, args) ->
176 let name = TyCon.tyConName tycon in
177 -- TODO: Do something more robust than string matching
178 case Name.getOccString name of
184 mkVHDLId :: String -> AST.VHDLId
185 mkVHDLId = AST.unsafeVHDLBasicId