From: Christiaan Baaij Date: Thu, 2 Jul 2009 14:44:58 +0000 (+0200) Subject: We now output VHDL types in the correct order X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=f5f6d286f56ee1e822ece0258039ba2d2ce920aa;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git We now output VHDL types in the correct order --- diff --git a/Adders.hs b/Adders.hs index 672c83c..6ada7df 100644 --- a/Adders.hs +++ b/Adders.hs @@ -174,8 +174,8 @@ highordtest = \x -> xand a b = hwand a b -functiontest :: TFVec D4 (TFVec D3 Bit) -> TFVec D12 Bit -functiontest = \v -> let r = concat v in r +functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit) +functiontest = \v -> let r = (concat v, head v) in r xhwnot x = hwnot x diff --git a/HighOrdAlu.hs b/HighOrdAlu.hs index f7d4516..def7742 100644 --- a/HighOrdAlu.hs +++ b/HighOrdAlu.hs @@ -8,9 +8,9 @@ import Types import Data.Param.TFVec import Data.RangedWord -constant :: NaturalT n => e -> Op n e +constant :: e -> Op D4 e constant e a b = - copy e + (e +> (e +> (e +> (singleton e)))) invop :: Op n Bit invop a b = map hwnot a @@ -20,12 +20,14 @@ andop a b = zipWith hwand a b -- Is any bit set? --anyset :: (PositiveT n) => Op n Bit -anyset :: NaturalT n => Op n Bit +anyset :: (Bit -> Bit -> Bit) -> Op D4 Bit --anyset a b = copy undefined (a' `hwor` b') -anyset a b = constant (a' `hwor` b') a b +anyset f a b = constant (a' `hwor` b') a b where - a' = foldl hwor Low a - b' = foldl hwor Low b + a' = foldl f Low a + b' = foldl f Low b + +xhwor = hwor type Op n e = (TFVec n e -> TFVec n e -> TFVec n e) type Opcode = Bit @@ -38,4 +40,4 @@ alu op1 op2 opc a b = actual_alu :: Opcode -> TFVec D4 Bit -> TFVec D4 Bit -> TFVec D4 Bit --actual_alu = alu (constant Low) andop -actual_alu = alu anyset andop +actual_alu = alu (anyset xhwor) andop diff --git a/VHDL.hs b/VHDL.hs index e2eb962..13a9294 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -47,12 +47,11 @@ createDesignFiles binds = map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLState Map.empty Map.empty Map.empty + init_session = VHDLState Map.empty [] Map.empty Map.empty (units, final_session) = State.runState (createLibraryUnits binds) init_session tyfun_decls = map snd $ 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)) + ty_decls = final_session ^.vsTypeDecls 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) @@ -69,9 +68,6 @@ createDesignFiles binds = type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls subProgSpecs = map subProgSpec tyfun_decls subProgSpec = \(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 diff --git a/VHDLTools.hs b/VHDLTools.hs index 5f467b0..3b49b27 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -281,6 +281,7 @@ vhdl_ty msg ty = do Just (ty_id, ty_def) -> do -- TODO: Check name uniqueness modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def)) + modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) return ty_id Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" @@ -362,6 +363,7 @@ mk_vector_ty ty = do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm modA vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def))) + modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) let ty_def = AST.SubtypeIn vec_id (Just range) return (ty_id, ty_def) @@ -387,3 +389,7 @@ getFieldLabels ty = do case Map.lookup (OrdType ty) types of Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty) + +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 diff --git a/VHDLTypes.hs b/VHDLTypes.hs index c1d9332..61fb003 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -51,6 +51,8 @@ type SignatureMap = Map.Map CoreSyn.CoreBndr Entity data VHDLState = VHDLState { -- | A map of Core type -> VHDL Type vsTypes_ :: TypeMap, + -- | A list of type declarations + vsTypeDecls_ :: [AST.PackageDecItem], -- | A map of vector Core type -> VHDL type function vsTypeFuns_ :: TypeFunMap, -- | A map of HsFunction -> hardware signature (entity name, port names,