import qualified ForSyDe.Backend.VHDL.AST as AST
-- GHC API
+import CoreSyn
import qualified Type
import qualified Name
import qualified OccName
import qualified Var
import qualified TyCon
-import qualified CoreSyn
+import qualified DataCon
+import qualified CoreSubst
import Outputable ( showSDoc, ppr )
-- Local imports
init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
- ty_decls = Map.elems (final_session ^. vsTypes)
+ ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
ieee_context = [
AST.Library $ mkVHDLBasicId "IEEE",
mkUseAll ["IEEE", "std_logic_1164"],
full_context =
mkUseAll ["work", "types"]
: ieee_context
- type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
+ type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
-- Create a use foo.bar.all statement. Takes a list of components in the used
-- name. Must contain at least two components
-- least compile for now.
mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
+-- A single alt case must be a selector
+mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
+
+-- Multiple case alt are be conditional assignments and have only wild
+-- binders in the alts and only variables in the case values and a variable
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- first is the default case, if there is any.
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
+ let
+ cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
+ true_expr = (varToVHDLExpr true)
+ false_expr = (varToVHDLExpr false)
+ false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+ true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+ whenelse = AST.WhenElse true_wform cond_expr
+ dst_name = AST.NSimple (bndrToVHDLId bndr)
+ assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+ in
+ return $ AST.CSSASm assign
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
+
+-- Turn a variable reference into a AST expression
+varToVHDLExpr :: Var.Var -> AST.Expr
+varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
+
+-- Turn a constructor into an AST expression. For dataconstructors, this is
+-- only the constructor itself, not any arguments it has. Should not be called
+-- with a DEFAULT constructor.
+conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
+ where
+ tycon = DataCon.dataConTyCon dc
+ tyname = TyCon.tyConName tycon
+ dcname = DataCon.dataConName dc
+ 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"
+conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
+conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+
+
+
{-
mkConcSm sigs (UncondDef src dst) _ = do
src_expr <- vhdl_expr src
Just t -> return t
-- No type yet, try to construct it
Nothing -> do
- let new_ty = do
- -- Use the Maybe Monad for failing when one of these fails
- (tycon, args) <- Type.splitTyConApp_maybe ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
- "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
- otherwise -> Nothing
- -- Return new_ty when a new type was successfully created
- Maybe.fromMaybe
- (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
- new_ty
+ newty_maybe <- (construct_vhdl_ty ty)
+ case newty_maybe of
+ Just (ty_id, ty_def) -> do
+ -- TODO: Check name uniqueness
+ modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+ return ty_id
+ Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
+
+-- Construct a new VHDL type for the given Haskell type.
+construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
+construct_vhdl_ty ty = do
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "TFVec" -> do
+ res <- mk_vector_ty (tfvec_len ty) ty
+ return $ Just res
+ "SizedWord" -> do
+ res <- mk_vector_ty (sized_word_len ty) ty
+ return $ Just res
+ otherwise -> return Nothing
+ Nothing -> return $ Nothing
-- | Create a VHDL vector type
mk_vector_ty ::
Int -- ^ The length of the vector
-> Type.Type -- ^ The Haskell type to create a VHDL type for
- -> VHDLState AST.TypeMark -- The typemark created.
+ -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
mk_vector_ty len ty = do
-- Assume there is a single type argument
-- TODO: Use el_ty
let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
- let ty_dec = AST.TypeDec ty_id ty_def
- -- TODO: Check name uniqueness
- --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
- modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
- return ty_id
+ return (ty_id, ty_def)
builtin_types =
projects / matthijs / master-project / cλash.git / blobdiff