From: Christiaan Baaij Date: Fri, 19 Jun 2009 10:17:44 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=e230d86ae7135a268a72cdffba947a9011001ec2;hp=-c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Use highordtest in main, since that can now be normalized. Add a (fairly complete) set of transforms. Add is_lam and is_fun predicates. Add a inlinebind helper function. Add a substitute helper function. Print the type in the transform debug output. Add infrastructure for running core to core transformations. Add a higher order testcase. Add is_wild function to check for wild binders. Generate VHDL from Core instead of flat functions. Conflicts: Translator.hs VHDL.hs --- e230d86ae7135a268a72cdffba947a9011001ec2 diff --combined CoreTools.hs index 5fbe871,3dfaf50..a8dce3f --- a/CoreTools.hs +++ b/CoreTools.hs @@@ -11,11 -11,16 +11,16 @@@ import qualified HsExp import qualified HsTypes import qualified HsBinds import qualified RdrName + import qualified Name import qualified OccName import qualified TysWiredIn import qualified Bag import qualified DynFlags import qualified SrcLoc + import qualified CoreSyn + import qualified Var + import qualified Unique + import qualified CoreUtils import GhcTools import HsTools @@@ -56,24 -61,41 +61,41 @@@ sized_word_len ty -- | Evaluate a core Type representing type level int from the TypeLevel -- library to a real int. -eval_type_level_int :: Type.Type -> Int -eval_type_level_int ty = - unsafeRunGhc $ do - -- Automatically import modules for any fully qualified identifiers - setDynFlag DynFlags.Opt_ImplicitImportQualified - - let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt" - let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name - let undef = hsTypedUndef $ coreToHsType ty - let app = HsExpr.HsApp (to_int) (undef) - - core <- toCore [] app - execCore core +-- eval_type_level_int :: Type.Type -> Int +-- eval_type_level_int ty = +-- unsafeRunGhc $ do +-- -- Automatically import modules for any fully qualified identifiers +-- setDynFlag DynFlags.Opt_ImplicitImportQualified +-- +-- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt" +-- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name +-- let undef = hsTypedUndef $ coreToHsType ty +-- let app = HsExpr.HsApp (to_int) (undef) +-- +-- core <- toCore [] app +-- execCore core -- | Get the length of a FSVec type -fsvec_len :: Type.Type -> Int -fsvec_len ty = - eval_type_level_int len +tfvec_len :: Type.Type -> Int +tfvec_len ty = + eval_tfp_int len where (tycon, args) = Type.splitTyConApp ty [len, el_ty] = args + + -- Is this a wild binder? + is_wild :: CoreSyn.CoreBndr -> Bool + -- wild binders have a particular unique, that we copied from MkCore.lhs to + -- here. However, this comparison didn't work, so we'll just check the + -- occstring for now... TODO + --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1) + is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr + + -- Is the given core expression a lambda abstraction? + is_lam :: CoreSyn.CoreExpr -> Bool + is_lam (CoreSyn.Lam _ _) = True + is_lam _ = False + + -- Is the given core expression of a function type? + is_fun :: CoreSyn.CoreExpr -> Bool + is_fun = Type.isFunTy . CoreUtils.exprType diff --combined Main.hs index be0a0a0,0000000..be48aa3 mode 100644,000000..100644 --- a/Main.hs +++ b/Main.hs @@@ -1,6 -1,0 +1,6 @@@ +module Main where + +import Translator + +main = do - makeVHDL "Alu.hs" "exec" True ++ makeVHDL "Adders.hs" "highordtest" True diff --combined Translator.hs index f377152,3f60330..0f60277 --- a/Translator.hs +++ b/Translator.hs @@@ -1,6 -1,8 +1,8 @@@ module Translator where import qualified Directory import qualified List + import Debug.Trace + import qualified Control.Arrow as Arrow import GHC hiding (loadModule, sigName) import CoreSyn import qualified CoreUtils @@@ -26,6 -28,7 +28,7 @@@ import MonadUtils ( liftIO import Outputable ( showSDoc, ppr ) import GHC.Paths ( libdir ) import DynFlags ( defaultDynFlags ) + import qualified UniqSupply import List ( find ) import qualified List import qualified Monad @@@ -43,13 -46,14 +46,14 @@@ import Text.PrettyPrint.HughesPJ (rende import TranslatorTypes import HsValueMap import Pretty + import Normalize import Flatten import FlattenTypes import VHDLTypes import qualified VHDL -main = do - makeVHDL "Adders.hs" "highordtest" True +-- main = do +-- makeVHDL "Alu.hs" "exec" True makeVHDL :: String -> String -> Bool -> IO () makeVHDL filename name stateful = do @@@ -58,7 -62,7 +62,7 @@@ -- Translate to VHDL vhdl <- moduleToVHDL core [(name, stateful)] -- Write VHDL to file - let dir = "../vhdl/vhdl/" ++ name ++ "/" + let dir = "./vhdl/" ++ name ++ "/" mapM (writeVHDL dir) vhdl return () @@@ -81,25 -85,31 +85,31 @@@ listBind filename name = d moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] moduleToVHDL core list = do let (names, statefuls) = unzip list - --liftIO $ putStr $ prettyShow (cm_binds core) let binds = findBinds core names - --putStr $ prettyShow binds + -- Generate a UniqSupply + -- Running + -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . + -- on the compiler dir of ghc suggests that 'z' is not used to generate a + -- unique supply anywhere. + uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' -- Turn bind into VHDL - let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty) + let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty) mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl where -- Turns the given bind into VHDL - mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)] - mkVHDL binds statefuls = do + mkVHDL :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)] + mkVHDL uniqSupply binds statefuls = do + let binds'' = map (Arrow.second $ normalize uniqSupply) binds + let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds'' -- Add the builtin functions --mapM addBuiltIn builtin_funcs -- Create entities and architectures for them - Monad.zipWithM processBind statefuls binds - modA tsFlatFuncs (Map.map nameFlatFunction) - flatfuncs <- getA tsFlatFuncs - return $ VHDL.createDesignFiles flatfuncs + --Monad.zipWithM processBind statefuls binds + --modA tsFlatFuncs (Map.map nameFlatFunction) + --flatfuncs <- getA tsFlatFuncs + return $ VHDL.createDesignFiles binds' -- | Write the given design file to a file with the given name inside the -- given dir @@@ -126,7 -136,7 +136,7 @@@ loadModule filename --setTargets [target] --load LoadAllTargets --core <- GHC.compileToCoreSimplified "Adders.hs" - core <- GHC.compileToCoreSimplified filename + core <- GHC.compileToCoreModule filename return core -- | Extracts the named binds from the given module. @@@ -270,7 -280,7 +280,7 @@@ resolvFunc hsfunc = d -- Don't do anything if there is already a flat function for this hsfunc or -- when it is a builtin function. Monad.unless (Map.member hsfunc flatfuncmap) $ do - Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do + -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do -- New function, resolve it core <- getA tsCoreModule -- Find the named function diff --combined VHDL.hs index 846cd81,561c279..d177a10 --- a/VHDL.hs +++ b/VHDL.hs @@@ -16,6 -16,7 +16,7 @@@ import qualified Data.Monoid as Monoi import Data.Accessor import qualified Data.Accessor.MonadState as MonadState import Text.Regex.Posix + import Debug.Trace -- ForSyDe import qualified ForSyDe.Backend.VHDL.AST as AST @@@ -23,7 -24,10 +24,10 @@@ -- GHC API import qualified Type import qualified Name + import qualified OccName + import qualified Var import qualified TyCon + import qualified CoreSyn import Outputable ( showSDoc, ppr ) -- Local imports @@@ -34,22 -38,19 +38,22 @@@ import TranslatorType import HsValueMap import Pretty import CoreTools +import Constants +import Generate +import GlobalNameTable createDesignFiles :: - FlatFuncMap + [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -> [(AST.VHDLId, AST.DesignFile)] - createDesignFiles flatfuncmap = + createDesignFiles binds = (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) : map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLSession Map.empty builtin_funcs + init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable (units, final_session) = - State.runState (createLibraryUnits flatfuncmap) init_session + State.runState (createLibraryUnits binds) init_session ty_decls = Map.elems (final_session ^. vsTypes) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", @@@ -72,14 -73,12 +76,12 @@@ mkUseAll ss select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s) createLibraryUnits :: - FlatFuncMap + [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])] - createLibraryUnits flatfuncmap = do - let hsfuncs = Map.keys flatfuncmap - let flatfuncs = Map.elems flatfuncmap - entities <- Monad.zipWithM createEntity hsfuncs flatfuncs - archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs + createLibraryUnits binds = do + entities <- Monad.mapM createEntity binds + archs <- Monad.mapM createArchitecture binds return $ zipWith (\ent arch -> let AST.EntityDec id _ = ent in @@@ -89,68 -88,66 +91,66 @@@ -- | Create an entity for a given function createEntity :: - HsFunction -- | The function signature - -> FlatFunction -- | The FlatFunction + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function -> VHDLState AST.EntityDec -- | The resulting entity - createEntity hsfunc flatfunc = do - let sigs = flat_sigs flatfunc - let args = flat_args flatfunc - let res = flat_res flatfunc - args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args - res' <- Traversable.traverse (mkMap sigs) res - let ent_decl' = createEntityAST hsfunc args' res' + createEntity (fname, expr) = do + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + args' <- Monad.mapM mkMap args + -- There must be a let at top level + let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr + res' <- mkMap res + let ent_decl' = createEntityAST fname args' res' let AST.EntityDec entity_id _ = ent_decl' let signature = Entity entity_id args' res' - modA vsSignatures (Map.insert hsfunc signature) + modA vsSignatures (Map.insert (bndrToString fname) signature) return ent_decl' where mkMap :: - [(SignalId, SignalInfo)] - -> SignalId + --[(SignalId, SignalInfo)] + CoreSyn.CoreBndr -> VHDLState VHDLSignalMapElement -- We only need the vsTypes element from the state - mkMap sigmap = (\id -> - mkMap = MonadState.lift vsTypes . (\bndr -> ++ mkMap = (\bndr -> let - info = Maybe.fromMaybe - (error $ "Signal not found in the name map? This should not happen!") - (lookup id sigmap) - nm = Maybe.fromMaybe - (error $ "Signal not named? This should not happen!") - (sigName info) - ty = sigTy info + --info = Maybe.fromMaybe + -- (error $ "Signal not found in the name map? This should not happen!") + -- (lookup id sigmap) + -- Assume the bndr has a valid VHDL id already + id = bndrToVHDLId bndr + ty = Var.varType bndr in - if isPortSigUse $ sigUse info + if True -- isPortSigUse $ sigUse info then do type_mark <- vhdl_ty ty - return $ Just (mkVHDLExtId nm, type_mark) + return $ Just (id, type_mark) else return $ Nothing ) -- | Create the VHDL AST for an entity createEntityAST :: - HsFunction -- | The signature of the function we're working with - -> [VHDLSignalMap] -- | The entity's arguments - -> VHDLSignalMap -- | The entity's result - -> AST.EntityDec -- | The entity with the ent_decl filled in as well + CoreSyn.CoreBndr -- | The name of the function + -> [VHDLSignalMapElement] -- | The entity's arguments + -> VHDLSignalMapElement -- | The entity's result + -> AST.EntityDec -- | The entity with the ent_decl filled in as well - createEntityAST hsfunc args res = + createEntityAST name args res = AST.EntityDec vhdl_id ports where - vhdl_id = mkEntityId hsfunc - ports = concatMap (mapToPorts AST.In) args - ++ mapToPorts AST.Out res - ++ clk_port - mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec] - mapToPorts mode m = - Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m) + -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids. + vhdl_id = mkVHDLBasicId $ bndrToString name + ports = Maybe.catMaybes $ + map (mkIfaceSigDec AST.In) args + ++ [mkIfaceSigDec AST.Out res] + ++ [clk_port] -- Add a clk port if we have state - clk_port = if hasState hsfunc + clk_port = if True -- hasState hsfunc then - [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty] + Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty else - [] + Nothing -- | Create a port declaration mkIfaceSigDec :: @@@ -170,31 -167,31 +170,31 @@@ mkEntityId hsfunc -- | Create an architecture for a given function createArchitecture :: - HsFunction -- ^ The function signature - -> FlatFunction -- ^ The FlatFunction + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function -> VHDLState AST.ArchBody -- ^ The architecture for this function - createArchitecture hsfunc flatfunc = do - signaturemap <- getA vsSignatures - let signature = Maybe.fromMaybe - (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!") - (Map.lookup hsfunc signaturemap) - let entity_id = ent_id signature + createArchitecture (fname, expr) = do + --signaturemap <- getA vsSignatures + --let signature = Maybe.fromMaybe + -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!") + -- (Map.lookup hsfunc signaturemap) + let entity_id = mkVHDLBasicId $ bndrToString fname + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + -- There must be a let at top level + let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr + -- Create signal declarations for all internal and state signals - sig_dec_maybes <- mapM (mkSigDec' . snd) sigs + sig_dec_maybes <- mapM (mkSigDec' . fst) binds let sig_decs = Maybe.catMaybes $ sig_dec_maybes - -- Create concurrent statements for all signal definitions - statements <- Monad.zipWithM (mkConcSm sigs) defs [0..] + + statements <- Monad.mapM mkConcSm binds return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') where - sigs = flat_sigs flatfunc - args = flat_args flatfunc - res = flat_res flatfunc - defs = flat_defs flatfunc - procs = map mkStateProcSm (makeStatePairs flatfunc) + procs = map mkStateProcSm [] -- (makeStatePairs flatfunc) procs' = map AST.CSPSm procs -- mkSigDec only uses vsTypes from the state - mkSigDec' = MonadState.lift vsTypes . mkSigDec + mkSigDec' = mkSigDec -- | Looks up all pairs of old state, new state signals, together with -- the state id they represent. @@@ -223,16 -220,13 +223,13 @@@ mkStateProcSm (num, old, new) rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)] statement = AST.IfSm rising_edge_clk [assign] [] Nothing - mkSigDec :: SignalInfo -> VHDLState (Maybe AST.SigDec) - mkSigDec info = - let use = sigUse info in - if isInternalSigUse use || isStateSigUse use then do - type_mark <- vhdl_ty ty - return $ Just (AST.SigDec (getSignalId info) type_mark Nothing) -mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec) ++mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec) + mkSigDec bndr = + if True then do --isInternalSigUse use || isStateSigUse use then do + type_mark <- vhdl_ty $ Var.varType bndr + return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing) else return Nothing - where - ty = sigTy info -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo -- is not named. @@@ -242,28 -236,33 +239,33 @@@ getSignalId info (error $ "Unnamed signal? This should not happen!") (sigName info) - -- | Transforms a signal definition into a VHDL concurrent statement + -- | Transforms a core binding into a VHDL concurrent statement mkConcSm :: - [(SignalId, SignalInfo)] -- ^ The signals in the current architecture - -> SigDef -- ^ The signal definition - -> Int -- ^ A number that will be unique for all - -- concurrent statements in the architecture. + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation. - mkConcSm sigs (FApp hsfunc args res) num = do + mkConcSm (bndr, app@(CoreSyn.App _ _))= do signatures <- getA vsSignatures let + (CoreSyn.Var f, args) = CoreSyn.collectArgs app signature = Maybe.fromMaybe - (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!") - (Map.lookup hsfunc signatures) + (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") + (Map.lookup (bndrToString f) signatures) entity_id = ent_id signature - label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num) + label = bndrToString bndr -- Add a clk port if we have state - clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" - portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) + --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" + --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) + portmaps = mkAssocElems args bndr signature in return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) + -- GHC generates some funny "r = r" bindings in let statements before + -- simplification. This outputs some dummy ConcSM for these, so things will at + -- least compile for now. + mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] [] + + {- mkConcSm sigs (UncondDef src dst) _ = do src_expr <- vhdl_expr src let src_wform = AST.Wform [AST.WformElem src_expr Nothing] @@@ -282,7 -281,7 +284,7 @@@ -- Create a cast expression, which is just a function call using the -- type name as the function name. let litexpr = AST.PrimLit lit - ty_id <- MonadState.lift vsTypes (vhdl_ty ty) + ty_id <- vhdl_ty ty let ty_name = AST.NSimple ty_id let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] return $ AST.PrimFCall $ AST.FCall ty_name args @@@ -301,7 -300,7 +303,7 @@@ mkConcSm sigs (CondDef cond true false assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing) in return $ AST.CSSASm assign - + -} -- | Turn a SignalId into a VHDL Expr mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr mkIdExpr sigs id = @@@ -309,27 -308,29 +311,29 @@@ AST.PrimName src_name mkAssocElems :: - [(SignalId, SignalInfo)] -- | The signals in the current architecture - -> [SignalMap] -- | The signals that are applied to function - -> SignalMap -- | the signals in which to store the function result + [CoreSyn.CoreExpr] -- | The argument that are applied to function + -> CoreSyn.CoreBndr -- | The binder in which to store the result -> Entity -- | The entity to map against. -> [AST.AssocElem] -- | The resulting port maps - mkAssocElems sigmap args res entity = + mkAssocElems args res entity = -- Create the actual AssocElems Maybe.catMaybes $ zipWith mkAssocElem ports sigs where -- Turn the ports and signals from a map into a flat list. This works, -- since the maps must have an identical form by definition. TODO: Check -- the similar form? - arg_ports = concat (map Foldable.toList (ent_args entity)) - res_ports = Foldable.toList (ent_res entity) - arg_sigs = (concat (map Foldable.toList args)) - res_sigs = Foldable.toList res + arg_ports = ent_args entity + res_port = ent_res entity -- Extract the id part from the (id, type) tuple - ports = (map (fmap fst) (arg_ports ++ res_ports)) + ports = map (Monad.liftM fst) (res_port : arg_ports) -- Translate signal numbers into names - sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs)) + sigs = (bndrToString res : map (bndrToString.varBndr) args) + + -- Turns a Var CoreExpr into the Id inside it. Will of course only work for + -- simple Var CoreExprs, not complexer ones. + varBndr :: CoreSyn.CoreExpr -> Var.Id + varBndr (CoreSyn.Var id) = id -- | Look up a signal in the signal name map lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String @@@ -360,9 -361,9 +364,9 @@@ std_logic_ty :: AST.TypeMar std_logic_ty = AST.unsafeVHDLBasicId "std_logic" -- Translate a Haskell type to a VHDL type -vhdl_ty :: Type.Type -> TypeState AST.TypeMark +vhdl_ty :: Type.Type -> VHDLState AST.TypeMark vhdl_ty ty = do - typemap <- State.get + typemap <- getA vsTypes let builtin_ty = do -- See if this is a tycon and lookup its name (tycon, args) <- Type.splitTyConApp_maybe ty let name = Name.getOccString (TyCon.tyConName tycon) @@@ -379,7 -380,7 +383,7 @@@ (tycon, args) <- Type.splitTyConApp_maybe ty let name = Name.getOccString (TyCon.tyConName tycon) case name of - "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty + "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty otherwise -> Nothing -- Return new_ty when a new type was successfully created @@@ -391,7 -392,7 +395,7 @@@ mk_vector_ty :: Int -- ^ The length of the vector -> Type.Type -- ^ The Haskell type to create a VHDL type for - -> TypeState AST.TypeMark -- The typemark created. + -> VHDLState AST.TypeMark -- The typemark created. mk_vector_ty len ty = do -- Assume there is a single type argument @@@ -401,9 -402,7 +405,9 @@@ let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty let ty_dec = AST.TypeDec ty_id ty_def -- TODO: Check name uniqueness - State.modify (Map.insert (OrdType ty) (ty_id, ty_dec)) + --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec)) + modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec)) + modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id)) return ty_id @@@ -445,29 -444,43 +449,43 @@@ mkVHDLExtId s allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-" strip_invalid = filter (`elem` allowed) + -- Creates a VHDL Id from a binder + bndrToVHDLId :: + CoreSyn.CoreBndr + -> AST.VHDLId + + bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName + + -- Extracts the binder name as a String + bndrToString :: + CoreSyn.CoreBndr + -> String + + bndrToString = OccName.occNameString . Name.nameOccName . Var.varName + -- | A consise representation of a (set of) ports on a builtin function - type PortMap = HsValueMap (String, AST.TypeMark) + --type PortMap = HsValueMap (String, AST.TypeMark) -- | A consise representation of a builtin function - data BuiltIn = BuiltIn String [PortMap] PortMap + data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark) -- | Translate a list of concise representation of builtin functions to a -- SignatureMap mkBuiltins :: [BuiltIn] -> SignatureMap mkBuiltins = Map.fromList . map (\(BuiltIn name args res) -> - (HsFunction name (map useAsPort args) (useAsPort res), - Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res)) + (name, + Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res)) ) builtin_hsfuncs = Map.keys builtin_funcs builtin_funcs = mkBuiltins [ - 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)) + BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty), + BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty), + BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty), + BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty) ] -- | Map a port specification of a builtin function to a VHDL Signal to put in -- a VHDLSignalMap - toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap - toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty)) + toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement + toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty) diff --combined VHDLTypes.hs index f317167,784b097..e517a8b --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@@ -12,6 -12,7 +12,7 @@@ import qualified Data.Accessor.Templat -- GHC API imports import qualified Type + import qualified CoreSyn -- ForSyDe imports import qualified ForSyDe.Backend.VHDL.AST as AST @@@ -30,8 -31,8 +31,8 @@@ type VHDLSignalMap = HsValueMap VHDLSig -- ports. data Entity = Entity { ent_id :: AST.VHDLId, -- The id of the entity - ent_args :: [VHDLSignalMap], -- A mapping of each function argument to port names - ent_res :: VHDLSignalMap -- A mapping of the function result to port names + ent_args :: [VHDLSignalMapElement], -- A mapping of each function argument to port names + ent_res :: VHDLSignalMapElement -- A mapping of the function result to port names } deriving (Show); -- A orderable equivalent of CoreSyn's Type for use as a map key @@@ -44,25 -45,15 +45,25 @@@ instance Ord OrdType wher -- A map of a Core type to the corresponding type name type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) +-- A map of a vector Core type to the coressponding VHDL functions +type TypeFunMap = Map.Map OrdType [AST.SubProgBody] + -- A map of a Haskell function to a hardware signature - type SignatureMap = Map.Map HsFunction Entity + type SignatureMap = Map.Map String Entity +-- A map of a builtin function to VHDL function builder +type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr ) + data VHDLSession = VHDLSession { -- | A map of Core type -> VHDL Type - vsTypes_ :: TypeMap, + vsTypes_ :: TypeMap, + -- | A map of vector Core type -> VHDL type function + vsTypeFuns_ :: TypeFunMap, -- | A map of HsFunction -> hardware signature (entity name, port names, -- etc.) - vsSignatures_ :: SignatureMap + vsSignatures_ :: SignatureMap, + -- | A map of Vector HsFunctions -> VHDL function call + vsNameTable_ :: NameTable } -- Derive accessors