From: Christiaan Baaij Date: Mon, 22 Jun 2009 07:19:40 +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=91914df9b344ccf0bc3242dc28ce74a8d6721944;hp=ce21f6b5bc31049d9f663bab7c0f7984ccec5875;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: Recursively normalize binds. --- diff --git a/Adders.hs b/Adders.hs index d4c43ca..6cf3be5 100644 --- a/Adders.hs +++ b/Adders.hs @@ -10,6 +10,7 @@ import Prelude hiding ( import Language.Haskell.Syntax import Types import Data.Param.TFVec +import Data.RangedWord mainIO f = Sim.simulateIO (Sim.stateless f) () @@ -171,8 +172,8 @@ highordtest = \x -> in \c d -> op' d c -functiontest :: TFVec D4 Bit -> Bit -functiontest = \v -> let r = head v in r +functiontest :: TFVec D4 Bit -> RangedWord D3 -> Bit +functiontest = \v i -> let r = v!i in r highordtest2 = \a b -> case a of diff --git a/CoreTools.hs b/CoreTools.hs index a8dce3f..0dee471 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -58,6 +58,14 @@ sized_word_len ty = where (tycon, args) = Type.splitTyConApp ty [len] = args + +-- | Get the upperbound of a RangedWord type +ranged_word_bound :: Type.Type -> Int +ranged_word_bound ty = + eval_tfp_int len + where + (tycon, args) = Type.splitTyConApp ty + [len] = args -- | Evaluate a core Type representing type level int from the TypeLevel -- library to a real int. diff --git a/Generate.hs b/Generate.hs index 97d9488..2beacb8 100644 --- a/Generate.hs +++ b/Generate.hs @@ -26,12 +26,12 @@ genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements genUnconsVectorFuns elemTM vectorTM = [ AST.SubProgBody exSpec [] [exExpr] , AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet] - , AST.SubProgBody headSpec [] [headExpr] - , AST.SubProgBody lastSpec [] [lastExpr] - , AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet] - , AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet] - , AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet] - , AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet] + , AST.SubProgBody headSpec [] [headExpr] + , AST.SubProgBody lastSpec [] [lastExpr] + , AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet] + , AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet] + , AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet] + , AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet] ] where ixPar = AST.unsafeVHDLBasicId "ix" diff --git a/GlobalNameTable.hs b/GlobalNameTable.hs index ef4b25e..c860dcb 100644 --- a/GlobalNameTable.hs +++ b/GlobalNameTable.hs @@ -17,6 +17,6 @@ mkGlobalNameTable = Map.fromList globalNameTable :: NameTable globalNameTable = mkGlobalNameTable - [ (show ('(V.!)) , (2, genExprFCall2L exId ) ) - , ("head" , (1, genExprFCall1L headId ) ) + [ ("!" , (2, genExprFCall2L exId ) ) + , ("head" , (1, genExprFCall1L headId ) ) ] \ No newline at end of file diff --git a/VHDL.hs b/VHDL.hs index 8eb130f..f838cba 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -48,14 +48,16 @@ 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 builtin_funcs globalNameTable (units, final_session) = State.runState (createLibraryUnits binds) init_session ty_decls = Map.elems (final_session ^. vsTypes) + subty_decls = Map.elems (final_session ^. vsSubTypes) + tyfun_decls = Map.elems (final_session ^.vsTypeFuns) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], @@ -64,7 +66,12 @@ createDesignFiles binds = full_context = mkUseAll ["work", "types"] : ieee_context - type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls) + type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (packageTypeDecs ++ packageSubtypeDecs ++ subProgSpecs) + type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls) + packageTypeDecs = map (AST.PDITD . snd) ty_decls + packageSubtypeDecs = map (AST.PDISD . snd) subty_decls + subProgSpecs = concat (map subProgSpec tyfun_decls) + subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) -- Create a use foo.bar.all statement. Takes a list of components in the used -- name. Must contain at least two components @@ -443,6 +450,7 @@ vhdl_ty ty = do case name of "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty + "RangedWord" -> Just $ mk_natural_ty 0 (ranged_word_bound ty) ty otherwise -> Nothing -- Return new_ty when a new type was successfully created Maybe.fromMaybe @@ -468,6 +476,18 @@ mk_vector_ty len ty = do modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id)) return ty_id +mk_natural_ty :: + Int -- ^ The minimum bound (> 0) + -> Int -- ^ The maximum bound (> minimum bound) + -> Type.Type -- ^ The Haskell type to create a VHDL type for + -> VHDLState AST.TypeMark -- The typemark created. +mk_natural_ty min_bound max_bound ty = do + let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) + let ty_def = AST.SubtypeIn naturalTM (Nothing) + let ty_dec = AST.SubtypeDec ty_id ty_def + modA vsSubTypes (Map.insert (OrdType ty) (ty_id, ty_dec)) + return ty_id + builtin_types = Map.fromList [ diff --git a/VHDLTypes.hs b/VHDLTypes.hs index e517a8b..9b48579 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -45,6 +45,9 @@ instance Ord OrdType where -- A map of a Core type to the corresponding type name type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) +-- A map of a Core type to the corresponding VHDL subtype +type SubTypeMap = Map.Map OrdType (AST.VHDLId, AST.SubtypeDec) + -- A map of a vector Core type to the coressponding VHDL functions type TypeFunMap = Map.Map OrdType [AST.SubProgBody] @@ -57,6 +60,8 @@ type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr ) data VHDLSession = VHDLSession { -- | A map of Core type -> VHDL Type vsTypes_ :: TypeMap, + -- | A map of Core type -> VHDL SubType + vsSubTypes_ :: SubTypeMap, -- | A map of vector Core type -> VHDL type function vsTypeFuns_ :: TypeFunMap, -- | A map of HsFunction -> hardware signature (entity name, port names,