X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=ecf6406f95e3f3f621b835d74497eb4feb5b2110;hb=4e34d6b1baa6e0754432254fabc2fa822b755f0b;hp=a450c04962d21d8ae4b5803c0b72ce8878a8a114;hpb=81bbc7b720fe914d5655bd6a125925d54a62c5af;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index a450c04..ecf6406 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -30,6 +30,7 @@ import qualified Var import qualified Id import qualified IdInfo import qualified TyCon +import qualified TcType import qualified DataCon import qualified CoreSubst import qualified CoreUtils @@ -56,11 +57,12 @@ createDesignFiles binds = 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 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)) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], @@ -69,7 +71,7 @@ createDesignFiles binds = full_context = mkUseAll ["work", "types"] : ieee_context - type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (ty_decls ++ subProgSpecs) + type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (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) @@ -113,13 +115,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 @@ -143,16 +146,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] @@ -186,11 +188,11 @@ 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 @@ -258,13 +260,15 @@ mkConcSm :: 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 + --let valargs = filter isValArg args in if all is_var valargs then do labels <- getFieldLabels (CoreUtils.exprType app) let assigns = zipWith mkassign labels valargs @@ -284,9 +288,9 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do funSignatures <- getA vsNameTable case (Map.lookup (bndrToString f) funSignatures) of Just (arg_count, builder) -> - if length args == arg_count then + if length valargs == arg_count then let - sigs = map (bndrToString.varBndr) args + sigs = map (bndrToString.varBndr) valargs sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs func = builder sigsNames src_wform = AST.Wform [AST.WformElem func Nothing] @@ -295,7 +299,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do in return $ AST.CSSASm assign else - error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString args + 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 @@ -304,7 +308,7 @@ 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 -- Add a clk port if we have state @@ -568,11 +572,11 @@ construct_vhdl_ty ty = do let name = Name.getOccString (TyCon.tyConName tycon) case name of "TFVec" -> do - res <- mk_vector_ty (tfvec_len ty) ty - return $ Just $ (Arrow.second Left) res - "SizedWord" -> do - res <- mk_vector_ty (sized_word_len ty) ty - return $ Just $ (Arrow.second Left) res + res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) 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) ty return $ Just $ (Arrow.second Right) res @@ -612,17 +616,27 @@ mk_tycon_ty tycon args = -- | Create a VHDL vector type mk_vector_ty :: Int -- ^ The length of the vector + -> Type.Type -- ^ The Haskell element type of the Vector -> Type.Type -- ^ The Haskell type to create a VHDL type for - -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created. + -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- 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 +mk_vector_ty len el_ty 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.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)) - return (ty_id, ty_def) + 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 [naturalTM] el_ty_tm + modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def)) + modA vsTypeFuns (Map.insert (OrdType 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) @@ -684,35 +698,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