import qualified Module
import qualified Control.Monad.State as State
import Name
+import qualified Data.Map as Map
import Data.Generics
import NameEnv ( lookupNameEnv )
import HscTypes ( cm_binds, cm_types )
import Text.PrettyPrint.HughesPJ (render)
import TranslatorTypes
+import HsValueMap
import Pretty
import Flatten
+import FlattenTypes
import qualified VHDL
main =
core <- GHC.compileToCoreSimplified "Adders.hs"
--liftIO $ printBinds (cm_binds core)
let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"]
- liftIO $ printBinds binds
+ liftIO $ putStr $ prettyShow binds
-- Turn bind into VHDL
- let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession 0 [])
+ let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
-- Turns the given bind into VHDL
mkVHDL binds = do
-- Add the builtin functions
- --mapM (uncurry addFunc) builtin_funcs
+ mapM addBuiltIn builtin_funcs
-- Create entities and architectures for them
- mapM flattenBind binds
+ mapM processBind binds
+ modFuncs nameFlatFunction
+ modFuncs VHDL.createEntity
+ modFuncs VHDL.createArchitecture
+ -- Extract the library units generated from all the functions in the
+ -- session.
+ funcs <- getFuncs
+ let units = concat $ map VHDL.getLibraryUnits funcs
return $ AST.DesignFile
[]
- []
-
-printTarget (Target (TargetFile file (Just x)) obj Nothing) =
- print $ show file
-
-printBinds [] = putStr "done\n\n"
-printBinds (b:bs) = do
- printBind b
- putStr "\n"
- printBinds bs
-
-printBind (NonRec b expr) = do
- putStr "NonRec: "
- printBind' (b, expr)
-
-printBind (Rec binds) = do
- putStr "Rec: \n"
- foldl1 (>>) (map printBind' binds)
-
-printBind' (b, expr) = do
- putStr $ getOccString b
- putStr $ showSDoc $ ppr expr
- putStr "\n"
+ units
findBind :: [CoreBind] -> String -> Maybe CoreBind
findBind binds lookfor =
NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
) binds
--- | Flattens the given bind and adds it to the session. Then (recursively)
--- finds any functions it uses and does the same with them.
-flattenBind ::
- CoreBind -- The binder to flatten
+-- | Processes the given bind as a top level bind.
+processBind ::
+ CoreBind -- The bind to process
-> VHDLState ()
-flattenBind (Rec _) = error "Recursive binders not supported"
-
-flattenBind bind@(NonRec var expr) = do
+processBind (Rec _) = error "Recursive binders not supported"
+processBind bind@(NonRec var expr) = do
-- Create the function signature
let ty = CoreUtils.exprType expr
let hsfunc = mkHsFunction var ty
- --hwfunc <- mkHWFunction bind hsfunc
- -- Add it to the session
- --addFunc hsfunc hwfunc
+ flattenBind hsfunc bind
+
+-- | Flattens the given bind into the given signature and adds it to the
+-- session. Then (recursively) finds any functions it uses and does the same
+-- with them.
+flattenBind ::
+ HsFunction -- The signature to flatten into
+ -> CoreBind -- The bind to flatten
+ -> VHDLState ()
+
+flattenBind _ (Rec _) = error "Recursive binders not supported"
+
+flattenBind hsfunc bind@(NonRec var expr) = do
+ -- Flatten the function
let flatfunc = flattenFunction hsfunc bind
- addFunc hsfunc flatfunc
- let used_hsfuncs = map appFunc (apps flatfunc)
+ addFunc hsfunc
+ setFlatFunc hsfunc flatfunc
+ let used_hsfuncs = map appFunc (flat_apps flatfunc)
State.mapM resolvFunc used_hsfuncs
return ()
HsFunction -- | The function to look for
-> VHDLState ()
-resolvFunc hsfunc =
- return ()
+resolvFunc hsfunc = do
+ -- See if the function is already known
+ func <- getFunc hsfunc
+ case func of
+ -- Already known, do nothing
+ Just _ -> do
+ return ()
+ -- New function, resolve it
+ Nothing -> do
+ -- Get the current module
+ core <- getModule
+ -- Find the named function
+ let bind = findBind (cm_binds core) name
+ case bind of
+ Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+ Just b -> flattenBind hsfunc b
+ where
+ name = hsFuncName hsfunc
-- | Translate a top level function declaration to a HsFunction. i.e., which
-- interface will be provided by this function. This function essentially
error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+-- | Adds signal names to the given FlatFunction
+nameFlatFunction ::
+ HsFunction
+ -> FuncData
+ -> FuncData
+
+nameFlatFunction hsfunc fdata =
+ let func = flatFunc fdata in
+ case func of
+ -- Skip (builtin) functions without a FlatFunction
+ Nothing -> fdata
+ -- Name the signals in all other functions
+ Just flatfunc ->
+ let s = flat_sigs flatfunc in
+ let s' = map (\(id, (SignalInfo Nothing ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) ty)) s in
+ let flatfunc' = flatfunc { flat_sigs = s' } in
+ fdata { flatFunc = Just flatfunc' }
+
-- | Splits a tuple type into a list of element types, or Nothing if the type
-- is not a tuple type.
splitTupleType ::
Nothing
Nothing -> Nothing
+-- | A consise representation of a (set of) ports on a builtin function
+type PortMap = HsValueMap (String, AST.TypeMark)
+-- | A consise representation of a builtin function
+data BuiltIn = BuiltIn String [PortMap] PortMap
+
+-- | Translate a concise representation of a builtin function to something
+-- that can be put into FuncMap directly.
+addBuiltIn :: BuiltIn -> VHDLState ()
+addBuiltIn (BuiltIn name args res) = do
+ addFunc hsfunc
+ where
+ hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
+
+builtin_funcs =
+ [
+ BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
+ BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
+ BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
+ BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
+ ]
+
-- vim: set ts=8 sw=2 sts=2 expandtab:
projects / matthijs / master-project / cλash.git / blobdiff