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
-- 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
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.
-- | 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,
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)
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
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
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 ([],[])
(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 ::
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)
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
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))
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))
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
-- 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.
-- 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.
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
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
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
-----------------------------------------------------------------------------
-- 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.
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
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
-- | 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)
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'
-- ======================================================
-- = Input Buffer: Buffers incomming inputs when needed =
-- ======================================================
+{-# ANN circBuffer (InitState 'initCircState) #-}
circBuffer :: CircState ->
((DataInt, Discr), Shift) ->
(CircState, Cell, Cell)
, 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 )
-- ============================================
-- = 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
-- ===================================================
-- = 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'
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
(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)]
-
projects / matthijs / master-project / cλash.git / commitdiff