X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=72b0a925ec8554753109ff04946eb667a6581c04;hb=dfdf88c20bacf8f8e7863cf7a41c86c869735f6f;hp=5f4b5833628c2805f26954f5f67fcd6ba4d16983;hpb=a8edf6a046d6f95f197673623f2ab78f946cf1b7;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index 5f4b583..72b0a92 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -30,8 +30,10 @@ import qualified Var import qualified Id import qualified IdInfo import qualified TyCon +import qualified TcType import qualified DataCon import qualified CoreSubst +import qualified CoreUtils import Outputable ( showSDoc, ppr ) -- Local imports @@ -51,14 +53,19 @@ createDesignFiles :: -> [(AST.VHDLId, AST.DesignFile)] createDesignFiles binds = - (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) : + (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) : map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable + init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable (units, final_session) = State.runState (createLibraryUnits binds) init_session - ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes) + tyfun_decls = Map.elems (final_session ^.vsTypeFuns) + ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes) + vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes)) + tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def + tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing) + tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], @@ -67,7 +74,13 @@ createDesignFiles binds = full_context = mkUseAll ["work", "types"] : ieee_context - type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls) + type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs) + type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls) + subProgSpecs = concat (map subProgSpec tyfun_decls) + subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) + mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem + mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def + mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def -- Create a use foo.bar.all statement. Takes a list of components in the used -- name. Must contain at least two components @@ -105,13 +118,14 @@ createEntity (fname, expr) = do -- 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 vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname + let ent_decl' = createEntityAST vhdl_id args' res' let AST.EntityDec entity_id _ = ent_decl' let signature = Entity entity_id args' res' - modA vsSignatures (Map.insert (bndrToString fname) signature) + modA vsSignatures (Map.insert fname signature) return ent_decl' where - mkMap :: + mkMap :: --[(SignalId, SignalInfo)] CoreSyn.CoreBndr -> VHDLState VHDLSignalMapElement @@ -135,16 +149,15 @@ createEntity (fname, expr) = do -- | Create the VHDL AST for an entity createEntityAST :: - CoreSyn.CoreBndr -- | The name of the function + AST.VHDLId -- | 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 name args res = +createEntityAST vhdl_id args res = AST.EntityDec vhdl_id ports where -- 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] @@ -178,21 +191,24 @@ createArchitecture :: -> VHDLState AST.ArchBody -- ^ The architecture for this function 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 + signaturemap <- getA vsSignatures + let signature = Maybe.fromMaybe + (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!") + (Map.lookup fname signaturemap) + let entity_id = ent_id signature -- 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 + let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr - -- Create signal declarations for all internal and state signals - sig_dec_maybes <- mapM (mkSigDec' . fst) binds + -- Create signal declarations for all binders in the let expression, except + -- for the output port (that will already have an output port declared in + -- the entity). + sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds) let sig_decs = Maybe.catMaybes $ sig_dec_maybes - statements <- Monad.mapM mkConcSm binds + statementss <- Monad.mapM mkConcSm binds + let statements = concat statementss return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') where procs = map mkStateProcSm [] -- (makeStatePairs flatfunc) @@ -246,26 +262,72 @@ getSignalId info = -- | Transforms a core binding into a VHDL concurrent statement mkConcSm :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process - -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation. + -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. + + +-- Ignore Cast expressions, they should not longer have any meaning as long as +-- the type works out. +mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) + +-- For simple a = b assignments, just generate an unconditional signal +-- assignment. This should only happen for dataconstructors without arguments. +-- TODO: Integrate this with the below code for application (essentially this +-- is an application without arguments) +mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)] mkConcSm (bndr, app@(CoreSyn.App _ _))= do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + let valargs' = filter isValArg args + let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs' case Var.globalIdVarDetails f of + IdInfo.DataConWorkId dc -> + -- It's a datacon. Create a record from its arguments. + -- First, filter out type args. TODO: Is this the best way to do this? + -- The types should already have been taken into acocunt when creating + -- the signal, so this should probably work... + --let valargs = filter isValArg args in + if all is_var valargs then do + labels <- getFieldLabels (CoreUtils.exprType app) + return $ zipWith mkassign labels valargs + else + error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args + where + mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm + mkassign label (Var arg) = + let sel_name = mkSelectedName bndr label in + mkUncondAssign (Right sel_name) (varToVHDLExpr arg) IdInfo.VanillaGlobal -> do - -- It's a global value imported from elsewhere. These can be builting + -- It's a global value imported from elsewhere. These can be builtin -- functions. funSignatures <- getA vsNameTable + signatures <- getA vsSignatures case (Map.lookup (bndrToString f) funSignatures) of - Just funSignature -> - let - sigs = map (bndrToString.varBndr) args - sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs - func = (snd funSignature) sigsNames - src_wform = AST.Wform [AST.WformElem func Nothing] - dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) - assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) - in - return $ AST.CSSASm assign + Just (arg_count, builder) -> + if length valargs == arg_count then + case builder of + Left funBuilder -> + let + sigs = map (varToVHDLExpr.varBndr) valargs + func = funBuilder sigs + src_wform = AST.Wform [AST.WformElem func Nothing] + dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) + assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) + in + return [AST.CSSASm assign] + Right genBuilder -> + let + ty = Var.varType bndr + len = tfvec_len ty + sigs = map varBndr valargs + signature = Maybe.fromMaybe + (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!") + (Map.lookup (head sigs) signatures) + arg_names = map (mkVHDLExtId . bndrToString) (tail sigs) + dst_name = mkVHDLExtId (bndrToString bndr) + genSm = genBuilder len signature (arg_names ++ [dst_name]) + in return [AST.CSGSm genSm] + else + error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f IdInfo.NotGlobalId -> do signatures <- getA vsSignatures @@ -274,22 +336,18 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do let signature = Maybe.fromMaybe (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") - (Map.lookup (bndrToString f) signatures) + (Map.lookup f signatures) entity_id = ent_id signature - label = bndrToString bndr + label = "comp_ins_" ++ bndrToString bndr -- Add a clk port if we have state --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" + 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 + portmaps = clk_port : mkAssocElems args bndr signature in - return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) + return [AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)] details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details --- 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") [] [] - -- A single alt case must be a selector. This means thee scrutinee is a simple -- variable, the alternative is a dataalt with a single non-wild binder that -- is also returned. @@ -302,7 +360,7 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = let label = labels!!i let sel_name = mkSelectedName scrut label let sel_expr = AST.PrimName sel_name - return $ mkUncondAssign bndr sel_expr + return [mkUncondAssign (Left bndr) sel_expr] Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr) _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr) @@ -313,39 +371,40 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = -- first is the default case, if there is any. mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = let - cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con) + cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con) true_expr = (varToVHDLExpr true) false_expr = (varToVHDLExpr false) in - return $ mkCondAssign bndr cond_expr true_expr false_expr + return [mkCondAssign (Left bndr) cond_expr true_expr false_expr] mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives" mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee" +mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr -- Create an unconditional assignment statement mkUncondAssign :: - CoreBndr -- ^ The signal to assign to + Either CoreBndr AST.VHDLName -- ^ The signal to assign to -> AST.Expr -- ^ The expression to assign -> AST.ConcSm -- ^ The resulting concurrent statement -mkUncondAssign bndr expr = mkAssign bndr Nothing expr +mkUncondAssign dst expr = mkAssign dst Nothing expr -- Create a conditional assignment statement mkCondAssign :: - CoreBndr -- ^ The signal to assign to + Either CoreBndr AST.VHDLName -- ^ The signal to assign to -> AST.Expr -- ^ The condition -> AST.Expr -- ^ The value when true -> AST.Expr -- ^ The value when false -> AST.ConcSm -- ^ The resulting concurrent statement -mkCondAssign bndr cond true false = mkAssign bndr (Just (cond, true)) false +mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false -- Create a conditional or unconditional assignment statement mkAssign :: - CoreBndr -> -- ^ The signal to assign to + Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for -- and the value to assign when true. AST.Expr -> -- ^ The value to assign when false or no condition AST.ConcSm -- ^ The resulting concurrent statement -mkAssign bndr cond false_expr = +mkAssign dst cond false_expr = let -- I'm not 100% how this assignment AST works, but this gets us what we -- want... @@ -357,7 +416,9 @@ mkAssign bndr cond false_expr = [AST.WhenElse true_wform cond_expr] Nothing -> [] false_wform = AST.Wform [AST.WformElem false_expr Nothing] - dst_name = AST.NSimple (bndrToVHDLId bndr) + dst_name = case dst of + Left bndr -> AST.NSimple (bndrToVHDLId bndr) + Right name -> name assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing) in AST.CSSASm assign @@ -381,18 +442,31 @@ getFieldLabels ty = do -- Get the types map, lookup and unpack the VHDL TypeDef types <- getA vsTypes case Map.lookup (OrdType ty) types of - Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems + Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty) -- Turn a variable reference into a AST expression varToVHDLExpr :: Var.Var -> AST.Expr -varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var - --- Turn a constructor into an AST expression. For dataconstructors, this is --- only the constructor itself, not any arguments it has. Should not be called --- with a DEFAULT constructor. -conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr -conToVHDLExpr (DataAlt dc) = AST.PrimLit lit +varToVHDLExpr var = + case Id.isDataConWorkId_maybe var of + Just dc -> dataconToVHDLExpr dc + -- This is a dataconstructor. + -- Not a datacon, just another signal. Perhaps we should check for + -- local/global here as well? + Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var + +-- Turn a alternative constructor into an AST expression. For +-- dataconstructors, this is only the constructor itself, not any arguments it +-- has. Should not be called with a DEFAULT constructor. +altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr +altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc + +altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet" +altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!" + +-- Turn a datacon (without arguments!) into a VHDL expression. +dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr +dataconToVHDLExpr dc = AST.PrimLit lit where tycon = DataCon.dataConTyCon dc tyname = TyCon.tyConName tycon @@ -401,9 +475,6 @@ conToVHDLExpr (DataAlt dc) = AST.PrimLit lit -- TODO: Do something more robust than string matching "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false" -conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet" -conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!" - {- @@ -528,24 +599,27 @@ vhdl_ty ty = do Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty) -- Construct a new VHDL type for the given Haskell type. -construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef)) +construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) construct_vhdl_ty ty = do case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do let name = Name.getOccString (TyCon.tyConName tycon) case name of "TFVec" -> do - res <- mk_vector_ty (tfvec_len ty) ty - return $ Just res - "SizedWord" -> do - res <- mk_vector_ty (sized_word_len ty) ty - return $ Just res + res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) + return $ Just $ (Arrow.second Right) res + -- "SizedWord" -> do + -- res <- mk_vector_ty (sized_word_len ty) ty + -- return $ Just $ (Arrow.second Left) res + "RangedWord" -> do + res <- mk_natural_ty 0 (ranged_word_bound ty) + return $ Just $ (Arrow.second Right) res -- Create a custom type from this tycon otherwise -> mk_tycon_ty tycon args Nothing -> return $ Nothing -- | Create VHDL type for a custom tycon -mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef)) +mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) mk_tycon_ty tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type @@ -564,7 +638,7 @@ mk_tycon_ty tycon args = -- TODO: Special handling for tuples? let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) let ty_def = AST.TDR $ AST.RecordTypeDef elems - return $ Just (ty_id, ty_def) + return $ Just (ty_id, Left ty_def) dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon) where -- Create a subst that instantiates all types passed to the tycon @@ -576,19 +650,37 @@ mk_tycon_ty tycon args = -- | Create a VHDL vector type mk_vector_ty :: Int -- ^ The length of the vector - -> Type.Type -- ^ The Haskell type to create a VHDL type for - -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created. - -mk_vector_ty len ty = do - -- Assume there is a single type argument - let ty_id = mkVHDLExtId $ "vector_" ++ (show len) - -- TODO: Use el_ty - let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] - let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty - modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id)) + -> Type.Type -- ^ The Haskell element type of the Vector + -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created. + +mk_vector_ty len el_ty = do + elem_types_map <- getA vsElemTypes + el_ty_tm <- vhdl_ty el_ty + let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) + let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] + let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map + case existing_elem_ty of + Just t -> do + let ty_def = AST.SubtypeIn t (Just range) + return (ty_id, ty_def) + Nothing -> do + let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) + let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm + modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def)) + modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) + let ty_def = AST.SubtypeIn vec_id (Just range) + return (ty_id, ty_def) + +mk_natural_ty :: + Int -- ^ The minimum bound (> 0) + -> Int -- ^ The maximum bound (> minimum bound) + -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created. +mk_natural_ty min_bound max_bound = do + let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) + let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound)) + let ty_def = AST.SubtypeIn naturalTM (Just range) return (ty_id, ty_def) - - + builtin_types = Map.fromList [ ("Bit", std_logic_ty), @@ -638,35 +730,15 @@ bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varN bndrToString :: CoreSyn.CoreBndr -> String - bndrToString = OccName.occNameString . Name.nameOccName . Var.varName +-- Get the string version a Var's unique +varToStringUniq = show . Var.varUnique + -- Extracts the string version of the name nameToString :: Name.Name -> String nameToString = OccName.occNameString . Name.nameOccName --- | 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 [(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) -> - (name, - Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res)) - ) - -builtin_hsfuncs = Map.keys builtin_funcs -builtin_funcs = mkBuiltins - [ - 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) - ] - recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] -- | Map a port specification of a builtin function to a VHDL Signal to put in