From 466f80bdde9511508c38e951d208a2a52c90c7da Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Tue, 10 Nov 2009 14:49:47 +0100 Subject: [PATCH] Fixed VHDL Type generation, vhdlTy now uses HType's to generate VHDL Types. Logic from vhdlTy moved to mkHType --- "c\316\273ash/CLasH/Translator.hs" | 3 +- .../CLasH/Translator/TranslatorTypes.hs" | 14 +- "c\316\273ash/CLasH/Utils/GhcTools.hs" | 4 +- "c\316\273ash/CLasH/VHDL.hs" | 3 +- "c\316\273ash/CLasH/VHDL/Generate.hs" | 151 +++--- "c\316\273ash/CLasH/VHDL/VHDLTools.hs" | 465 ++++++++---------- reducer.hs | 60 ++- 7 files changed, 335 insertions(+), 365 deletions(-) diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index e2993d2..8884506 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -33,6 +33,7 @@ import CLasH.Utils import CLasH.Utils.Core.CoreTools import CLasH.Utils.GhcTools import CLasH.VHDL +import CLasH.VHDL.VHDLTools import CLasH.VHDL.Testbench -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial @@ -128,7 +129,7 @@ runTranslatorSession env session = do -- on the compiler dir of ghc suggests that 'z' is not used to generate -- a unique supply anywhere. uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' - let init_typestate = TypeState Map.empty [] Map.empty Map.empty env + let init_typestate = TypeState builtin_types [] Map.empty Map.empty env let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty return $ State.evalState session init_state diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index 12ca6ed..2591e66 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -46,19 +46,21 @@ instance Eq OrdType where instance Ord OrdType where compare (OrdType a) (OrdType b) = Type.tcCmpType a b -data HType = StdType OrdType | - ADTType String [HType] | +data HType = AggrType String [HType] | EnumType String [String] | VecType Int HType | + UVecType HType | SizedWType Int | RangedWType Int | SizedIType Int | - BuiltinType String - deriving (Eq, Ord) + BuiltinType String | + StateType + deriving (Eq, Ord, Show) -- A map of a Core type to the corresponding type name, or Nothing when the -- type would be empty. -type TypeMap = Map.Map HType (Maybe (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)) +type TypeMapRec = Maybe (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) +type TypeMap = Map.Map HType TypeMapRec -- A map of a vector Core element type and function name to the coressponding -- VHDLId of the function and the function body. @@ -70,7 +72,7 @@ data TypeState = TypeState { -- | A map of Core type -> VHDL Type tsTypes_ :: TypeMap, -- | A list of type declarations - tsTypeDecls_ :: [AST.PackageDecItem], + tsTypeDecls_ :: [Maybe AST.PackageDecItem], -- | A map of vector Core type -> VHDL type function tsTypeFuns_ :: TypeFunMap, tsTfpInts_ :: TfpIntMap, diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 373e9cf..c11b548 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -217,9 +217,9 @@ findInitStates statec annsc mod = do extractInits (InitState x) = Just x extractInits _ = Nothing zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c]) - zipMwith _ Nothing _ = Nothing + zipMWith _ Nothing _ = Nothing zipMWith f (Just as) bs = Just $ zipWith f as bs - + -- | Make a complete spec out of a three conditions findSpec :: (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool) diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" index 8429a57..762a0f4 100644 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -84,7 +84,8 @@ createTypesPackage :: createTypesPackage = do tyfuns <- getA (tsType .> tsTypeFuns) let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns) - ty_decls <- getA (tsType .> tsTypeDecls) + ty_decls_maybes <- getA (tsType .> tsTypeDecls) + let ty_decls = Maybe.catMaybes ty_decls_maybes let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs) let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 7c604d6..3c738a0 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -71,7 +71,7 @@ getEntity fname = Utils.makeCached fname tsEntities $ do ty = Var.varType bndr error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr in do - type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty + type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty case type_mark_maybe of Just type_mark -> return $ Just (id, type_mark) Nothing -> return Nothing @@ -134,7 +134,9 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do let init_state = Map.lookup fname initSmap -- Create a state proc, if needed (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of - ([in_state], [out_state], Nothing) -> error $ "No initial state defined for: " ++ show fname + ([in_state], [out_state], Nothing) -> do + nonEmpty <- hasNonEmptyType in_state + if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[]) ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval) ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname ([], [], Nothing) -> return ([],[]) @@ -170,41 +172,36 @@ mkStateProcSm :: (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements mkStateProcSm (old, new, res) = do - nonempty <- hasNonEmptyType old - if nonempty - then do - let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res - type_mark_old_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType old) - let type_mark_old = Maybe.fromJust type_mark_old_maybe - type_mark_res_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType res) - let type_mark_res' = Maybe.fromJust type_mark_res_maybe - let type_mark_res = if type_mark_old == type_mark_res' then - type_mark_res' - else - error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res' - let resvalid = mkVHDLBasicId $ varToString res ++ "val" - let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing - let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing] - let res_assign = AST.SigAssign (varToVHDLName old) reswform - let blocklabel = mkVHDLBasicId $ "state" - let statelabel = mkVHDLBasicId $ "stateupdate" - let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge" - let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing] - let clk_assign = AST.SigAssign (varToVHDLName old) wform - let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)] - let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'") - signature <- getEntity res - let entity_id = ent_id signature - let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res) - let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature - let reset_statement = mkComponentInst reslabel entity_id portmaps - let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]] - let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing - let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId] [statement] - let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate] - return ([block],[res]) - else - return ([],[]) + let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res + type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old) + let type_mark_old = Maybe.fromJust type_mark_old_maybe + type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res) + let type_mark_res' = Maybe.fromJust type_mark_res_maybe + let type_mark_res = if type_mark_old == type_mark_res' then + type_mark_res' + else + error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res' + let resvalid = mkVHDLExtId $ varToString res ++ "val" + let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing + let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing] + let res_assign = AST.SigAssign (varToVHDLName old) reswform + let blocklabel = mkVHDLBasicId $ "state" + let statelabel = mkVHDLBasicId $ "stateupdate" + let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge" + let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing] + let clk_assign = AST.SigAssign (varToVHDLName old) wform + let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)] + let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'") + signature <- getEntity res + let entity_id = ent_id signature + let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res) + let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature + let reset_statement = mkComponentInst reslabel entity_id portmaps + let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]] + let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing + let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement] + let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate] + return ([block],[res]) -- | Transforms a core binding into a VHDL concurrent statement mkConcSm :: @@ -244,11 +241,25 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) bndrs' <- Monad.filterM hasNonEmptyType bndrs case List.elemIndex sel_bndr bndrs' of Just i -> do - labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut) - let label = labels!!i - let sel_name = mkSelectedName (varToVHDLName scrut) label - let sel_expr = AST.PrimName sel_name - return ([mkUncondAssign (Left bndr) sel_expr], []) + htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut) + htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + case htypeScrt == htypeBndr of + True -> do + let sel_name = varToVHDLName scrut + let sel_expr = AST.PrimName sel_name + return ([mkUncondAssign (Left bndr) sel_expr], []) + otherwise -> do + case htypeScrt of + Right (AggrType _ _) -> do + labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut) + let label = labels!!i + let sel_name = mkSelectedName (varToVHDLName scrut) label + let sel_expr = AST.PrimName sel_name + return ([mkUncondAssign (Left bndr) sel_expr], []) + _ -> do -- error $ "DIE!" + let sel_name = varToVHDLName scrut + let sel_expr = AST.PrimName sel_name + return ([mkUncondAssign (Left bndr) sel_expr], []) Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) @@ -294,7 +305,7 @@ argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr) argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr) argToVHDLExpr (Left expr) = MonadState.lift tsType $ do let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!" - ty_maybe <- vhdl_ty errmsg expr + ty_maybe <- vhdlTy errmsg expr case ty_maybe of Just _ -> do vhdl_expr <- varToVHDLExpr $ exprToVar expr @@ -594,7 +605,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do let tmp_ty = Type.mkAppTy nvec (Var.varType start) let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty -- TODO: Handle Nothing - Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty + Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res)) @@ -825,7 +836,7 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do let tmp_ty = Var.varType res let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty -- TODO: Handle Nothing - Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty + Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start)) let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res)) @@ -892,13 +903,13 @@ genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do let (tup',ramvec) = Type.splitAppTy tup let Just realram = Type.coreView ramvec let Just (tycon, types) = Type.splitTyConApp_maybe realram - Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types) + Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types) -- Make the intermediate vector let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing -- Get the data_out name - reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) - let resname' = varToVHDLName res - let resname = mkSelectedName resname' (reslabels!!0) + -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) + let resname = varToVHDLName res + -- let resname = mkSelectedName resname' (reslabels!!0) let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int let assign = mkUncondAssign (Right resname) argexpr @@ -983,14 +994,26 @@ genApplication dst f args = do -- It's a datacon. Create a record from its arguments. Left bndr -> do -- We have the bndr, so we can get at the type - labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr) - args' <- argsToVHDLExprs args - return $ (zipWith mkassign labels $ args', []) - where - mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm - mkassign label arg = - let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in - mkUncondAssign (Right sel_name) arg + htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args + case argsNostate of + [arg] -> do + [arg'] <- argsToVHDLExprs [arg] + return $ ([mkUncondAssign dst arg'], []) + otherwise -> do + case htype of + Right (AggrType _ _) -> do + labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr) + args' <- argsToVHDLExprs argsNostate + return $ (zipWith mkassign labels $ args', []) + where + mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm + mkassign label arg = + let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in + mkUncondAssign (Right sel_name) arg + _ -> do -- error $ "DIE!" + args' <- argsToVHDLExprs argsNostate + return $ ([mkUncondAssign dst (head args')], []) Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" IdInfo.DataConWrapId dc -> case dst of -- It's a datacon. Create a record from its arguments. @@ -1037,7 +1060,12 @@ genApplication dst f args = do -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR! -- f' <- MonadState.lift tsType $ varToVHDLExpr f -- return $ ([mkUncondAssign dst f'], []) - error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f)) + errtype <- case dst of + Left bndr -> do + htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + return (show htype) + Right vhd -> return $ show vhd + error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) IdInfo.ClassOpId cls -> do -- FIXME: Not looking for what instance this class op is called for -- Is quite stupid of course. @@ -1060,12 +1088,13 @@ vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId vectorFunId el_ty fname = do let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty -- TODO: Handle the Nothing case? - Just elemTM <- vhdl_ty error_msg el_ty + Just elemTM <- vhdlTy error_msg el_ty -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in -- the VHDLState or something. let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM) typefuns <- getA tsTypeFuns - case Map.lookup (StdType $ OrdType el_ty, fname) typefuns of + el_htype <- mkHType error_msg el_ty + case Map.lookup (UVecType el_htype, fname) typefuns of -- Function already generated, just return it Just (id, _) -> return id -- Function not generated yet, generate it @@ -1073,7 +1102,7 @@ vectorFunId el_ty fname = do let functions = genUnconsVectorFuns elemTM vectorTM case lookup fname functions of Just body -> do - modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, fname) (function_id, (fst body)) + modA tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body)) mapM_ (vectorFunId el_ty) (snd body) return function_id Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 1378376..546fc12 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -194,25 +194,21 @@ altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative shou dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr dataconToVHDLExpr dc = do typemap <- getA tsTypes - htype_either <- mkHType (DataCon.dataConRepType dc) + htype_either <- mkHTypeEither (DataCon.dataConRepType dc) case htype_either of -- No errors Right htype -> do - let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap - case existing_ty of - Just ty -> do - let dcname = DataCon.dataConName dc - let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname - return lit - Nothing -> do - let tycon = DataCon.dataConTyCon dc - let tyname = TyCon.tyConName tycon - let dcname = DataCon.dataConName dc - let lit = case Name.getOccString tyname of - -- 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" - return $ AST.PrimLit lit + let dcname = DataCon.dataConName dc + case htype of + (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" + (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false" + otherwise -> do + let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap + case existing_ty of + Just ty -> do + let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname + return lit + Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc -- Error when constructing htype Left err -> error err @@ -298,224 +294,237 @@ mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index]) ----------------------------------------------------------------------------- -- Functions dealing with VHDL types ----------------------------------------------------------------------------- - --- | Maps the string name (OccName) of a type to the corresponding VHDL type, --- for a few builtin types. +builtin_types :: TypeMap builtin_types = Map.fromList [ - ("Bit", Just std_logicTM), - ("Bool", Just booleanTM), -- TysWiredIn.boolTy - ("Dec", Just integerTM) + (BuiltinType "Bit", Just (std_logicTM, Nothing)), + (BuiltinType "Bool", Just (booleanTM, Nothing)), -- TysWiredIn.boolTy + (BuiltinType "Dec", Just (integerTM, Nothing)) ] --- Translate a Haskell type to a VHDL type, generating a new type if needed. --- Returns an error value, using the given message, when no type could be --- created. Returns Nothing when the type is valid, but empty. -vhdl_ty :: (TypedThing t, Outputable.Outputable t) => - String -> t -> TypeSession (Maybe AST.TypeMark) -vhdl_ty msg ty = do - tm_either <- vhdl_ty_either ty - case tm_either of - Right tm -> return tm - Left err -> error $ msg ++ "\n" ++ err - --- Translate a Haskell type to a VHDL type, generating a new type if needed. --- Returns either an error message or the resulting type. -vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) => - t -> TypeSession (Either String (Maybe AST.TypeMark)) -vhdl_ty_either tything = - case getType tything of - Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything - Just ty -> vhdl_ty_either' ty +-- Is the given type representable at runtime? +isReprType :: Type.Type -> TypeSession Bool +isReprType ty = do + ty_either <- mkHTypeEither ty + return $ case ty_either of + Left _ -> False + Right _ -> True -vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark)) -vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty - | otherwise = do - typemap <- getA tsTypes - htype_either <- mkHType ty +mkHType :: (TypedThing t, Outputable.Outputable t) => + String -> t -> TypeSession HType +mkHType msg ty = do + htype_either <- mkHTypeEither ty case htype_either of - -- No errors - Right htype -> do - 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) - Map.lookup name builtin_types - -- If not a builtin type, try the custom types - let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap - case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of - -- Found a type, return it - Just t -> return (Right t) - -- No type yet, try to construct it - Nothing -> do - newty_either <- (construct_vhdl_ty ty) - case newty_either of - Right newty -> do - -- TODO: Check name uniqueness - modA tsTypes (Map.insert htype newty) - case newty of - Just (ty_id, ty_def) -> do - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) - return (Right $ Just ty_id) - Nothing -> return $ Right Nothing - Left err -> return $ Left $ - "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" - ++ err - -- Error when constructing htype - Left err -> return $ Left err + Right htype -> return htype + Left err -> error $ msg ++ err --- Construct a new VHDL type for the given Haskell type. Returns an error --- message or the resulting typemark and typedef. -construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) --- State types don't generate VHDL -construct_vhdl_ty ty | isStateType ty = return $ Right Nothing -construct_vhdl_ty ty = do +mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => + t -> TypeSession (Either String HType) +mkHTypeEither tything = do + case getType tything of + Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything + Just ty -> mkHTypeEither' ty + +mkHTypeEither' :: Type.Type -> TypeSession (Either String HType) +mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty + | isStateType ty = return $ Right StateType + | otherwise = do case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do + typemap <- getA tsTypes let name = Name.getOccString (TyCon.tyConName tycon) - case name of - "TFVec" -> mk_vector_ty ty - "SizedWord" -> mk_unsigned_ty ty - "SizedInt" -> mk_signed_ty ty - "RangedWord" -> do - bound <- tfp_to_int (ranged_word_bound_ty ty) - mk_natural_ty 0 bound - -- Create a custom type from this tycon - otherwise -> mk_tycon_ty ty tycon args - Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n") + let builtinTyMaybe = Map.lookup (BuiltinType name) typemap + case builtinTyMaybe of + (Just x) -> return $ Right $ BuiltinType name + Nothing -> do + case name of + "TFVec" -> do + let el_ty = tfvec_elem ty + elem_htype_either <- mkHTypeEither el_ty + case elem_htype_either of + -- Could create element type + Right elem_htype -> do + len <- tfp_to_int (tfvec_len_ty ty) + return $ Right $ VecType len elem_htype + -- Could not create element type + Left err -> return $ Left $ + "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err + "SizedWord" -> do + len <- tfp_to_int (sized_word_len_ty ty) + return $ Right $ SizedWType len + "SizedInt" -> do + len <- tfp_to_int (sized_word_len_ty ty) + return $ Right $ SizedIType len + "RangedWord" -> do + bound <- tfp_to_int (ranged_word_bound_ty ty) + return $ Right $ RangedWType bound + otherwise -> do + mkTyConHType tycon args + Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty --- | Create VHDL type for a custom tycon -mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -mk_tycon_ty ty tycon args = +mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType) +mkTyConHType tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type - [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n") + [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon [dc] -> do let arg_tys = DataCon.dataConRepArgTys dc - -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a - -- violation? Or does it only mean not to apply it again to the same - -- subject? let real_arg_tys = map (CoreSubst.substTy subst) arg_tys - elem_tys_either <- mapM vhdl_ty_either real_arg_tys - case Either.partitionEithers elem_tys_either of + let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys + elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate + case Either.partitionEithers elem_htys_either of + ([], [elem_hty]) -> do + return $ Right elem_hty -- No errors in element types - ([], elem_tys') -> do - -- Throw away all empty members - case Maybe.catMaybes elem_tys' of - [] -> -- No non-empty members - return $ Right Nothing - elem_tys -> do - let elems = zipWith AST.ElementDec recordlabels elem_tys - -- For a single construct datatype, build a record with one field for - -- each argument. - -- TODO: Add argument type ids to this, to ensure uniqueness - -- TODO: Special handling for tuples? - let elem_names = concat $ map prettyShow elem_tys - let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names - let ty_def = AST.TDR $ AST.RecordTypeDef elems - let tupshow = mkTupleShow elem_tys ty_id - let htype = ADTType (nameToString (TyCon.tyConName tycon)) (map (\x -> StdType (OrdType x)) real_arg_tys) - modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) - return $ Right $ Just (ty_id, Left ty_def) + ([], elem_htys) -> do + return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys -- There were errors in element types (errors, _) -> return $ Left $ - "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" + "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" ++ (concat errors) dcs -> do let arg_tys = concat $ map DataCon.dataConRepArgTys dcs let real_arg_tys = map (CoreSubst.substTy subst) arg_tys case real_arg_tys of - [] -> do - let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs - let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) - let ty_def = AST.TDE $ AST.EnumTypeDef elems - let enumShow = mkEnumShow elems ty_id - let htype = EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) - modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) - return $ Right $ Just (ty_id, Left ty_def) + [] -> + return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) xs -> return $ Left $ "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n" where - -- Create a subst that instantiates all types passed to the tycon - -- TODO: I'm not 100% sure that this is the right way to do this. It seems - -- to work so far, though.. tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) + +-- Translate a Haskell type to a VHDL type, generating a new type if needed. +-- Returns an error value, using the given message, when no type could be +-- created. Returns Nothing when the type is valid, but empty. +vhdlTy :: (TypedThing t, Outputable.Outputable t) => + String -> t -> TypeSession (Maybe AST.TypeMark) +vhdlTy msg ty = do + htype <- mkHType msg ty + tm <- vhdlTyMaybe htype + return tm + +vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark) +vhdlTyMaybe htype = do + typemap <- getA tsTypes + -- If not a builtin type, try the custom types + let existing_ty = Map.lookup htype typemap + case existing_ty of + -- Found a type, return it + Just (Just (t, _)) -> return $ Just t + Just (Nothing) -> return Nothing + -- No type yet, try to construct it + Nothing -> do + newty <- (construct_vhdl_ty htype) + modA tsTypes (Map.insert htype newty) + case newty of + Just (ty_id, ty_def) -> do + modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) + return $ Just ty_id + Nothing -> return Nothing + +-- Construct a new VHDL type for the given Haskell type. Returns an error +-- message or the resulting typemark and typedef. +construct_vhdl_ty :: HType -> TypeSession TypeMapRec +-- State types don't generate VHDL +construct_vhdl_ty htype = do + case htype of + StateType -> return Nothing + (SizedWType w) -> mkUnsignedTy w + (SizedIType i) -> mkSignedTy i + (RangedWType u) -> mkNaturalTy 0 u + (VecType n e) -> mkVectorTy (VecType n e) + -- Create a custom type from this tycon + otherwise -> mkTyconTy htype + +-- | Create VHDL type for a custom tycon +mkTyconTy :: HType -> TypeSession TypeMapRec +mkTyconTy htype = + case htype of + (AggrType tycon args) -> do + elemTysMaybe <- mapM vhdlTyMaybe args + case Maybe.catMaybes elemTysMaybe of + [] -> -- No non-empty members + return Nothing + elem_tys -> do + let elems = zipWith AST.ElementDec recordlabels elem_tys + let elem_names = concat $ map prettyShow elem_tys + let ty_id = mkVHDLExtId $ tycon ++ elem_names + let ty_def = AST.TDR $ AST.RecordTypeDef elems + let tupshow = mkTupleShow elem_tys ty_id + modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) + return $ Just (ty_id, Just $ Left ty_def) + (EnumType tycon dcs) -> do + let elems = map mkVHDLExtId dcs + let ty_id = mkVHDLExtId tycon + let ty_def = AST.TDE $ AST.EnumTypeDef elems + let enumShow = mkEnumShow elems ty_id + modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) + return $ Just (ty_id, Just $ Left ty_def) + otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype + where -- Generate a bunch of labels for fields of a record recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] -- | Create a VHDL vector type -mk_vector_ty :: - Type.Type -- ^ The Haskell type of the Vector - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) +mkVectorTy :: + HType -- ^ The Haskell type of the Vector + -> TypeSession TypeMapRec -- ^ An error message or The typemark created. -mk_vector_ty ty = do - types_map <- getA tsTypes - env <- getA tsHscEnv - let (nvec_l, nvec_el) = Type.splitAppTy ty - let (nvec, leng) = Type.splitAppTy nvec_l - let vec_ty = Type.mkAppTy nvec nvec_el - len <- tfp_to_int (tfvec_len_ty ty) - let el_ty = tfvec_elem ty - el_ty_tm_either <- vhdl_ty_either el_ty - case el_ty_tm_either of - -- Could create element type - Right (Just el_ty_tm) -> do - let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) +mkVectorTy (VecType len elHType) = do + typesMap <- getA tsTypes + elTyTmMaybe <- vhdlTyMaybe elHType + case elTyTmMaybe of + (Just elTyTm) -> do + let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-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 $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map - case existing_elem_ty of + let existing_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap + case existing_uvec_ty of Just (Just t) -> do let ty_def = AST.SubtypeIn t (Just range) - return (Right $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right 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 tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def)))) - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) - let vecShowFuns = mkVectorShow el_ty_tm vec_id - mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns + let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm) + let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm + modA tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def)))) + modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))]) + let vecShowFuns = mkVectorShow elTyTm vec_id + mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) - return (Right $ Just (ty_id, Right ty_def)) - -- Empty element type? Empty vector type then. TODO: Does this make sense? - -- Probably needs changes in the builtin functions as well... - Right Nothing -> return $ Right Nothing - -- Could not create element type - Left err -> return $ Left $ - "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" - ++ err - -mk_natural_ty :: + return (Just (ty_id, Just $ Right ty_def)) + Nothing -> return Nothing +mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype + +mkNaturalTy :: Int -- ^ The minimum bound (> 0) -> Int -- ^ The maximum bound (> minimum bound) - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) + -> TypeSession TypeMapRec -- ^ An error message or The typemark created. -mk_natural_ty min_bound max_bound = do +mkNaturalTy min_bound max_bound = do let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound))) let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)] let ty_def = AST.SubtypeIn unsignedTM (Just range) - return (Right $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right ty_def)) -mk_unsigned_ty :: - Type.Type -- ^ Haskell type of the unsigned integer - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -mk_unsigned_ty ty = do - size <- tfp_to_int (sized_word_len_ty ty) +mkUnsignedTy :: + Int -- ^ Haskell type of the unsigned integer + -> TypeSession TypeMapRec +mkUnsignedTy size = do let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn unsignedTM (Just range) - return (Right $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right ty_def)) -mk_signed_ty :: - Type.Type -- ^ Haskell type of the signed integer - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -mk_signed_ty ty = do - size <- tfp_to_int (sized_int_len_ty ty) +mkSignedTy :: + Int -- ^ Haskell type of the signed integer + -> TypeSession TypeMapRec +mkSignedTy size = do let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn signedTM (Just range) - return (Right $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, -- which must result in a record type. @@ -523,98 +532,20 @@ getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId] getFieldLabels ty = do -- Ensure that the type is generated (but throw away it's VHDLId) let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." - vhdl_ty error_msg ty + vhdlTy error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef types <- getA tsTypes -- Assume the type for which we want labels is really translatable - Right htype <- mkHType ty + htype <- mkHType error_msg ty case Map.lookup htype types of - Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems + Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems Just Nothing -> return [] -- The type is empty - _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty) + _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show htype) -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 - -mkHType :: Type.Type -> TypeSession (Either String HType) -mkHType ty = do - -- FIXME: Do we really need to do this here again? - 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) - Map.lookup name builtin_types - case builtin_ty of - Just typ -> - return $ Right $ BuiltinType $ prettyShow typ - Nothing -> - case Type.splitTyConApp_maybe ty of - Just (tycon, args) -> do - let name = Name.getOccString (TyCon.tyConName tycon) - case name of - "TFVec" -> do - let el_ty = tfvec_elem ty - elem_htype_either <- mkHType el_ty - case elem_htype_either of - -- Could create element type - Right elem_htype -> do - len <- tfp_to_int (tfvec_len_ty ty) - return $ Right $ VecType len elem_htype - -- Could not create element type - Left err -> return $ Left $ - "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" - ++ err - "SizedWord" -> do - len <- tfp_to_int (sized_word_len_ty ty) - return $ Right $ SizedWType len - "SizedInt" -> do - len <- tfp_to_int (sized_word_len_ty ty) - return $ Right $ SizedIType len - "RangedWord" -> do - bound <- tfp_to_int (ranged_word_bound_ty ty) - return $ Right $ RangedWType bound - otherwise -> do - mkTyConHType tycon args - Nothing -> return $ Right $ StdType $ OrdType ty - --- FIXME: Do we really need to do this here again? -mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType) -mkTyConHType tycon args = - case TyCon.tyConDataCons tycon of - -- Not an algebraic type - [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n" - [dc] -> do - let arg_tys = DataCon.dataConRepArgTys dc - let real_arg_tys = map (CoreSubst.substTy subst) arg_tys - elem_htys_either <- mapM mkHType real_arg_tys - case Either.partitionEithers elem_htys_either of - -- No errors in element types - ([], elem_htys) -> do - return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys - -- There were errors in element types - (errors, _) -> return $ Left $ - "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" - ++ (concat errors) - dcs -> do - let arg_tys = concat $ map DataCon.dataConRepArgTys dcs - let real_arg_tys = map (CoreSubst.substTy subst) arg_tys - case real_arg_tys of - [] -> - return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) - xs -> return $ Left $ - "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n" - where - tyvars = TyCon.tyConTyVars tycon - subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) - --- Is the given type representable at runtime? -isReprType :: Type.Type -> TypeSession Bool -isReprType ty = do - ty_either <- vhdl_ty_either ty - return $ case ty_either of - Left _ -> False - Right _ -> True - +mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem +mytydecl (_, Nothing) = Nothing +mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def +mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def tfp_to_int :: Type.Type -> TypeSession Int tfp_to_int ty = do @@ -806,7 +737,7 @@ genExprPCall2 entid arg1 arg2 = mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec) mkSigDec bndr = do let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr) + type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr) case type_mark_maybe of Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) Nothing -> return Nothing @@ -814,4 +745,4 @@ mkSigDec bndr = do -- | Does the given thing have a non-empty type? hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => t -> TranslatorSession Bool -hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing) +hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing) diff --git a/reducer.hs b/reducer.hs index 7a8bde3..410b881 100644 --- a/reducer.hs +++ b/reducer.hs @@ -100,15 +100,10 @@ data ReducerRecord = Reducer { discrState :: DiscrState type ReducerState = State ReducerRecord -data ReducerZeroRecord = ReducerZ { i0 :: ArrayIndex - , inp :: CircState - , pipe :: - , - } - -- =========================================================== -- = Discrimintor: Hands out new discriminator to the system = -- =========================================================== +{-# ANN discriminator (InitState 'initDiscrState) #-} discriminator :: DiscrState -> (DataInt, ArrayIndex) -> (DiscrState, (DataInt, Discr), Bool) discriminator (State (DiscrR {..})) (data_in, index) = ( State ( DiscrR { prev_index = index , cur_discr = cur_discr' @@ -125,6 +120,7 @@ discriminator (State (DiscrR {..})) (data_in, index) = ( State ( DiscrR { prev_ -- ====================================================== -- = Input Buffer: Buffers incomming inputs when needed = -- ====================================================== +{-# ANN circBuffer (InitState 'initCircState) #-} circBuffer :: CircState -> ((DataInt, Discr), Shift) -> (CircState, Cell, Cell) @@ -136,7 +132,7 @@ circBuffer (State (Circ {..})) (inp,shift) = ( State ( Circ { mem = mem' , out1, out2 ) where - n = fromIntegerT (undefined :: AdderDepth) + (n :: RangedWord AdderDepth) = fromInteger (fromIntegerT (undefined :: AdderDepth)) (rdptr',count') | shift == 0 = (rdptr , count + 1) | shift == 1 = if rdptr == 0 then (n , count ) else (rdptr - 1, count ) @@ -155,6 +151,7 @@ circBuffer (State (Circ {..})) (inp,shift) = ( State ( Circ { mem = mem' -- ============================================ -- = Simulated pipelined floating point adder = -- ============================================ +{-# ANN fpAdder (InitState 'initPipeState) #-} fpAdder :: FpAdderState -> (Cell, Cell) -> (FpAdderState, Cell) fpAdder (State pipe) (arg1, arg2) = (State pipe', pipe_out) where @@ -195,7 +192,8 @@ resBuff (State (Outp {..})) (pipe_out, new_cell, index, (discrN, new_discr)) = ( -- =================================================== -- = Optimized Partial Result Buffer, uses BlockRAMs = --- =================================================== +-- =================================================== +{-# ANN resBuffO (InitState 'initResultState) #-} resBuffO :: OutputStateO -> ( Cell, Cell, ArrayIndex, (Discr, Bool)) -> (OutputStateO, Cell, OutputSignal) resBuffO (State (OutpO {..})) (pipe_out, new_cell, index, (discrN, new_discr)) = ( State ( OutpO { valid_mem = valid_mem' , mem1 = mem1' @@ -267,7 +265,7 @@ runReducerIO = do let input = siminput let istate = initstate let output = run reducer istate input - mapM_ (\x -> putStr $ ("(" P.++ (show x) P.++ ")\n")) output + mapM_ (\x -> putStr $ ((show x) P.++ "\n")) output return () runReducer = ( reduceroutput @@ -305,27 +303,35 @@ randominput n x = P.zip data_in index_in (P.take n (randindex 7 0)) main = runReducerIO +initDiscrState :: DiscrRecord +initDiscrState = DiscrR { prev_index = (255 :: ArrayIndex) + , cur_discr = (127 :: SizedWord DiscrSize) + } + +initCircState :: CircRecord +initCircState = Circ { mem = copy (0::DataInt,0::Discr) + , rdptr = (14 :: RangedWord AdderDepth) + , wrptr = (14 :: RangedWord AdderDepth) + , count = (0 :: RangedWord (AdderDepth :+: D1)) + } + +initPipeState :: Vector AdderDepth Cell +initPipeState = copy notValid + +initResultState :: RAM DiscrRange CellType +initResultState = copy NotValid + initstate :: ReducerState -initstate = State ( Reducer { discrState = State ( DiscrR { prev_index = (255 :: ArrayIndex) - , cur_discr = (127 :: SizedWord DiscrSize) - }) - , inputState = State ( Circ { mem = copy (0::DataInt,0::Discr) - , rdptr = (14 :: RangedWord AdderDepth) - , wrptr = (14 :: RangedWord AdderDepth) - , count = (0 :: RangedWord (AdderDepth :+: D1)) - }) - , pipeState = State ( copy notValid ) - -- , resultState = State ( Outp { res_mem = copy notValid - -- , lut = State (copy (0::ArrayIndex)) - -- }) - , resultState = State ( OutpO { valid_mem = copy NotValid - , mem1 = State (copy (0::DataInt)) - , mem2 = State (copy (0::DataInt)) - , lutm = State (copy (0::ArrayIndex)) - }) +initstate = State ( Reducer { discrState = State initDiscrState + , inputState = State initCircState + , pipeState = State initPipeState + , resultState = State OutpO { valid_mem = initResultState + , mem1 = State (copy (0::DataInt)) + , mem2 = State (copy (0::DataInt)) + , lutm = State (copy (0::ArrayIndex)) + } }) {-# ANN siminput TestInput #-} siminput :: [(DataInt, ArrayIndex)] siminput = [(1,0),(5,1),(12,1),(4,2),(9,2),(2,2),(13,2),(2,2),(6,2),(1,2),(12,2),(13,3),(6,3),(11,3),(2,3),(11,3),(5,4),(11,4),(1,4),(7,4),(3,4),(4,4),(5,5),(8,5),(8,5),(13,5),(10,5),(7,5),(9,6),(9,6),(3,6),(11,6),(14,6),(13,6),(10,6),(4,7),(15,7),(13,7),(10,7),(10,7),(6,7),(15,7),(9,7),(1,7),(7,7),(15,7),(3,7),(13,7),(7,8),(3,9),(13,9),(2,10),(9,11),(10,11),(9,11),(2,11),(14,12),(14,12),(12,13),(7,13),(9,13),(7,14),(14,15),(5,16),(6,16),(14,16),(11,16),(5,16),(5,16),(7,17),(1,17),(13,17),(10,18),(15,18),(12,18),(14,19),(13,19),(2,19),(3,19),(14,19),(9,19),(11,19),(2,19),(2,20),(3,20),(13,20),(3,20),(1,20),(9,20),(10,20),(4,20),(8,21),(4,21),(8,21),(4,21),(13,21),(3,21),(7,21),(12,21),(7,21),(13,21),(3,21),(1,22),(13,23),(9,24),(14,24),(4,24),(13,25),(6,26),(12,26),(4,26),(15,26),(3,27),(6,27),(5,27),(6,27),(12,28),(2,28),(8,28),(5,29),(4,29),(1,29),(2,29),(9,29),(10,29),(4,30),(6,30),(14,30),(11,30),(15,31),(15,31),(2,31),(14,31),(9,32),(3,32),(4,32),(6,33),(15,33),(1,33),(15,33),(4,33),(3,33),(8,34),(12,34),(14,34),(15,34),(4,35),(4,35),(12,35),(14,35),(3,36),(14,37),(3,37),(1,38),(15,39),(13,39),(13,39),(1,39),(5,40),(10,40),(14,40),(1,41),(6,42),(8,42),(11,42),(11,43),(2,43),(11,43),(8,43),(12,43),(15,44),(14,44),(6,44),(8,44),(9,45),(5,45),(12,46),(6,46),(5,46),(4,46),(2,46),(9,47),(7,48),(1,48),(3,48),(10,48),(1,48),(6,48),(6,48),(11,48),(11,48),(8,48),(14,48),(5,48),(11,49),(1,49),(3,49),(11,49),(8,49),(3,50),(8,51),(9,52),(7,52),(7,53),(8,53),(10,53),(11,53),(14,54),(11,54),(4,54),(6,55),(11,55),(5,56),(7,56),(6,56),(2,56),(4,56),(12,56),(4,57),(12,57),(2,57),(14,57),(9,57),(12,57),(5,57),(11,57),(7,58),(14,58),(2,58),(10,58),(2,58),(14,58),(7,58),(12,58),(1,58),(11,59),(8,59),(2,59),(14,59),(6,59),(6,59),(6,59),(14,59),(4,59),(1,59),(4,60),(14,60),(6,60),(4,60),(8,60),(12,60),(1,60),(8,60),(8,60),(13,60),(10,61),(11,61),(6,61),(14,61),(10,61),(3,62),(10,62),(7,62),(14,62),(10,62),(4,62),(6,62),(1,62),(3,63),(3,63),(1,63),(1,63),(15,63),(7,64),(1,65),(4,65),(11,66),(3,66),(13,66),(2,67),(2,67),(5,68),(15,68),(11,68),(8,68),(4,69),(11,69),(12,69),(8,69),(7,70),(9,70),(6,70),(9,70),(11,70),(14,70),(5,71),(7,71),(11,72),(5,72),(3,72),(2,72),(1,73),(13,73),(9,73),(14,73),(5,73),(6,73),(14,73),(13,73),(3,74),(13,74),(3,75),(14,75),(10,75),(5,75),(3,75),(8,75),(9,76),(7,76),(10,76),(10,76),(8,77),(10,77),(11,77),(8,77),(2,77),(9,77),(9,77),(12,77),(4,77),(14,77),(10,77),(7,77),(3,77),(10,78),(8,79),(14,79),(11,80),(15,81),(6,81),(4,82),(6,82),(1,82),(12,83),(6,83),(11,83),(12,83),(15,83),(13,83),(1,84),(2,84),(11,84),(5,84),(2,84),(2,84),(3,84),(4,85),(6,86),(5,86),(15,86),(8,86),(9,86),(9,87),(9,87),(12,87),(4,87),(13,88),(14,88),(10,88),(11,88),(7,88),(4,88),(9,88),(1,88),(4,88),(4,88),(12,88),(8,89),(3,89),(10,89),(10,89),(5,89),(14,89),(11,89),(10,89),(5,90),(6,90),(10,90),(9,90),(8,90),(10,90),(5,90),(11,90),(6,90),(10,90),(7,90),(3,91),(7,91),(5,91),(15,91),(4,91),(6,91),(8,91),(1,91),(8,91),(12,92),(8,93),(9,93),(12,94),(8,94),(5,94),(11,95),(13,95),(5,96),(12,96),(8,96),(4,96),(7,97),(6,97),(4,97),(1,98),(5,98),(12,98),(13,99),(7,100),(12,100),(4,100),(10,100),(2,101),(3,101),(14,101),(12,101),(5,101),(2,101),(14,101),(15,101),(7,102),(13,102),(5,102),(7,102),(4,102),(8,102),(12,103),(15,103),(2,103),(2,103),(6,103),(6,103),(1,104),(14,104),(15,105),(3,105),(13,105),(1,105),(8,105),(8,105),(15,105),(13,105),(13,105),(6,105),(9,105),(6,106),(14,107),(12,107),(7,108),(7,108),(6,109),(11,109),(14,110),(8,111),(5,111),(15,111),(14,111),(3,111),(13,112),(12,112),(5,112),(10,112),(7,112),(5,113),(3,113),(2,113),(1,113),(15,113),(8,113),(10,113),(3,114),(6,114),(15,114),(4,115),(8,115),(1,115),(12,115),(5,115),(6,116),(2,116),(13,116),(12,116),(6,116),(10,117),(8,117),(14,118),(10,118),(3,118),(15,119),(6,119),(6,120),(5,121),(8,121),(4,122),(1,122),(9,123),(12,123),(6,124),(10,124),(2,124),(11,124),(9,125),(8,126),(10,126),(11,126),(14,126),(2,126),(5,126),(7,126),(3,127),(12,127),(15,128),(4,128),(1,129),(14,129),(8,129),(9,129),(6,129),(1,130),(11,130),(2,130),(13,130),(14,131),(2,131),(15,131),(4,131),(15,131),(8,131),(3,131),(8,132),(1,132),(13,132),(8,132),(5,132),(11,132),(14,132),(14,132),(4,132),(14,132),(5,132),(11,133),(1,133),(15,133),(8,133),(12,133),(8,134),(14,135),(11,136),(9,137),(3,137),(15,138),(1,138),(1,139),(4,139),(3,140),(10,140),(8,141),(12,141),(4,141),(12,141),(13,141),(10,141),(4,142),(6,142),(15,142),(4,142),(2,143),(14,143),(5,143),(10,143),(8,143),(9,143),(3,143),(11,143),(6,144),(3,145),(9,145),(10,145),(6,145),(11,145),(4,145),(13,145),(5,145),(4,145),(1,145),(3,145),(15,145),(14,146),(11,146),(9,146),(9,146),(10,146),(9,146),(3,146),(2,146),(10,146),(6,146),(7,146),(3,147),(4,147),(15,147),(11,147),(15,147),(1,147),(15,147),(14,147),(15,147),(5,147),(15,147),(4,147),(2,148),(12,149),(12,150),(10,150),(1,150),(7,151),(4,151),(14,151),(15,151),(5,152),(11,153),(3,153),(1,153),(1,153),(12,153),(1,154),(1,155),(11,155),(8,155),(3,155),(8,155),(8,155),(2,155),(9,156),(6,156),(12,156),(1,156),(3,156),(8,156),(5,157),(9,157),(12,157),(6,157),(8,158),(15,159),(2,159),(10,160),(10,160),(2,160),(6,160),(10,160),(8,160),(13,160),(12,161),(15,161),(14,161),(10,161),(13,161),(14,161),(3,161),(2,161),(1,161),(11,161),(7,161),(8,161),(4,162),(9,163),(3,164),(5,164),(9,164),(9,165),(7,165),(1,165),(6,166),(14,166),(3,166),(14,166),(4,166),(14,167),(5,167),(13,167),(12,167),(13,168),(9,168)] - -- 2.30.2