import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Control.Monad as Monad
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Monoid as Monoid
-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
-import Debug.Trace
-
--- ForSyDe
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- VHDL Imports
import qualified Language.VHDL.AST as AST
-- GHC API
-import CoreSyn
+import qualified CoreSyn
import qualified Name
import qualified OccName
import qualified Var
import qualified Id
-import qualified IdInfo
import qualified TyCon
import qualified Type
import qualified DataCon
-- Create an unconditional assignment statement
mkUncondAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
-> AST.Expr -- ^ The expression to assign
-> AST.ConcSm -- ^ The resulting concurrent statement
mkUncondAssign dst expr = mkAssign dst Nothing expr
-- Create a conditional assignment statement
mkCondAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
-> AST.Expr -- ^ The condition
-> AST.Expr -- ^ The value when true
-> AST.Expr -- ^ The value when false
-- Create a conditional or unconditional assignment statement
mkAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
-> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
-- and the value to assign when true.
-> AST.Expr -- ^ The value to assign when false or no condition
AST.CSSASm assign
mkAltsAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
-> [AST.Expr] -- ^ The conditions
-> [AST.Expr] -- ^ The expressions
-> AST.ConcSm -- ^ The Alt assigns
mkAltsAssign dst conds exprs
- | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
+ | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
| otherwise =
let
whenelses = zipWith mkWhenElse conds exprs
-----------------------------------------------------------------------------
varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
-varToVHDLExpr var = do
+varToVHDLExpr var =
case Id.isDataConWorkId_maybe var of
Just dc -> dataconToVHDLExpr dc
-- This is a dataconstructor.
case Name.getOccString (TyCon.tyConName tycon) of
"Dec" -> do
len <- tfp_to_int ty
- return $ AST.PrimLit $ (show len)
+ return $ AST.PrimLit (show len)
otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
-- Turn a VHDLName into an AST expression
-- dataconstructors, this is only the constructor itself, not any arguments it
-- has. Should not be called with a DEFAULT constructor.
altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
-altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
+altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
-altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
-altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
+altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
+altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
-- Turn a datacon (without arguments!) into a VHDL expression.
dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
dataconToVHDLExpr dc = do
- typemap <- getA tsTypes
+ typemap <- MonadState.get tsTypes
htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
case htype_either of
-- No errors
(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
+ 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
varToVHDLId ::
CoreSyn.CoreBndr
-> AST.VHDLId
-varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
where
lowers :: String -> Int
lowers xs = length [x | x <- xs, Char.isLower x]
-- Strip leading numbers and underscores
strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
-- Strip multiple adjacent underscores
- strip_multiscore = concat . map (\cs ->
+ strip_multiscore = concatMap (\cs ->
case cs of
('_':_) -> "_"
_ -> cs
Left _ -> False
Right _ -> True
+-- | Turn a Core type into a HType, returning an error using the given
+-- error string if the type was not representable.
mkHType :: (TypedThing t, Outputable.Outputable t) =>
String -> t -> TypeSession HType
mkHType msg ty = do
Right htype -> return htype
Left err -> error $ msg ++ err
+-- | Turn a Core type into a HType. Returns either an error message if
+-- the type was not representable, or the HType generated.
mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
t -> TypeSession (Either String HType)
-mkHTypeEither tything = do
+mkHTypeEither tything =
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
+ | otherwise =
case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> do
- typemap <- getA tsTypes
+ typemap <- MonadState.get tsTypes
let name = Name.getOccString (TyCon.tyConName tycon)
let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
case builtinTyMaybe of
(Just x) -> return $ Right $ BuiltinType name
- Nothing -> do
+ Nothing ->
case name of
"TFVec" -> do
let el_ty = tfvec_elem ty
"RangedWord" -> do
bound <- tfp_to_int (ranged_word_bound_ty ty)
return $ Right $ RangedWType bound
- otherwise -> do
+ otherwise ->
mkTyConHType tycon args
Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
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
+ ([], [elem_hty]) ->
return $ Right elem_hty
-- No errors in element types
- ([], elem_htys) -> do
+ ([], elem_htys) ->
return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
-- There were errors in element types
(errors, _) -> return $ Left $
"\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 arg_tys = concatMap DataCon.dataConRepArgTys dcs
let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
case real_arg_tys of
[] ->
String -> t -> TypeSession (Maybe AST.TypeMark)
vhdlTy msg ty = do
htype <- mkHType msg ty
- tm <- vhdlTyMaybe htype
- return tm
+ vhdlTyMaybe htype
vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
vhdlTyMaybe htype = do
- typemap <- getA tsTypes
+ typemap <- MonadState.get tsTypes
-- If not a builtin type, try the custom types
let existing_ty = Map.lookup htype typemap
case existing_ty of
-- No type yet, try to construct it
Nothing -> do
newty <- (construct_vhdl_ty htype)
- modA tsTypes (Map.insert htype newty)
+ MonadState.modify tsTypes (Map.insert htype newty)
case newty of
Just (ty_id, ty_def) -> do
- modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
return $ Just ty_id
Nothing -> return Nothing
-- message or the resulting typemark and typedef.
construct_vhdl_ty :: HType -> TypeSession TypeMapRec
-- State types don't generate VHDL
-construct_vhdl_ty htype = do
+construct_vhdl_ty htype =
case htype of
StateType -> return Nothing
(SizedWType w) -> mkUnsignedTy w
return Nothing
elem_tys -> do
let elems = zipWith AST.ElementDec recordlabels elem_tys
- let elem_names = concat $ map prettyShow elem_tys
+ let elem_names = concatMap 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)
+ MonadState.modify 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)
+ MonadState.modify 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
-- ^ An error message or The typemark created.
mkVectorTy (VecType len elHType) = do
- typesMap <- getA tsTypes
+ typesMap <- MonadState.get 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_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap
+ 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)
Nothing -> do
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))])
+ MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
+ MonadState.modify 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
+ mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
let ty_def = AST.SubtypeIn vec_id (Just range)
return (Just (ty_id, Just $ Right ty_def))
+ -- Vector of empty elements becomes empty itself.
Nothing -> return Nothing
mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
vhdlTy error_msg ty
-- Get the types map, lookup and unpack the VHDL TypeDef
- types <- getA tsTypes
+ types <- MonadState.get tsTypes
-- Assume the type for which we want labels is really translatable
htype <- mkHType error_msg ty
case Map.lookup htype types of
- Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype)
Just Nothing -> return [] -- The type is empty
- _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show htype)
+ Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)
mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
mytydecl (_, Nothing) = Nothing
tfp_to_int :: Type.Type -> TypeSession Int
tfp_to_int ty = do
- hscenv <- getA tsHscEnv
+ hscenv <- MonadState.get tsHscEnv
let norm_ty = normalise_tfp_int hscenv ty
case Type.splitTyConApp_maybe norm_ty of
Just (tycon, args) -> do
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
- "Dec" -> do
- len <- tfp_to_int' ty
- return len
+ "Dec" ->
+ tfp_to_int' ty
otherwise -> do
- modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
+ MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1))
return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
tfp_to_int' :: Type.Type -> TypeSession Int
tfp_to_int' ty = do
- lens <- getA tsTfpInts
- hscenv <- getA tsHscEnv
+ lens <- MonadState.get tsTfpInts
+ hscenv <- MonadState.get tsHscEnv
let norm_ty = normalise_tfp_int hscenv ty
let existing_len = Map.lookup (OrdType norm_ty) lens
case existing_len of
Just len -> return len
Nothing -> do
let new_len = eval_tfp_int hscenv ty
- modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+ MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
return new_len
mkTupleShow ::
resId = AST.unsafeVHDLBasicId "res"
headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
-- return vec(0);
- headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
(AST.NSimple vecPar) [AST.PrimLit "0"])))
vecSlice init last = AST.PrimName (AST.NSlice
(AST.SliceName
AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
(AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
where
- signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
+ signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
showUnsignedExpr = AST.ReturnSm (Just $
AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
(AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
where
- unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
+ unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
-- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
-- showNaturalExpr = AST.ReturnSm (Just $
-- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)