X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=4f4e75cf122ac758be03066ec40c36f261ffbae1;hb=b62b2e3aa902db1f774c2f655b25e8428e2b1cf0;hp=561c2790d5537bc56d4f5b12d6d9505b2f2a30fb;hpb=3f12ee5d723fd8c01190c5971641141a8c7a9d98;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index 561c279..4f4e75c 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -22,12 +22,15 @@ import Debug.Trace 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 Id import qualified TyCon -import qualified CoreSyn +import qualified DataCon +import qualified CoreSubst import Outputable ( showSDoc, ppr ) -- Local imports @@ -38,6 +41,9 @@ import TranslatorTypes import HsValueMap import Pretty import CoreTools +import Constants +import Generate +import GlobalNameTable createDesignFiles :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] @@ -48,10 +54,10 @@ createDesignFiles binds = map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLSession Map.empty builtin_funcs + 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"], @@ -60,7 +66,7 @@ createDesignFiles binds = full_context = mkUseAll ["work", "types"] : ieee_context - type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls) + type_package = 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 @@ -109,7 +115,7 @@ createEntity (fname, expr) = do CoreSyn.CoreBndr -> VHDLState VHDLSignalMapElement -- We only need the vsTypes element from the state - mkMap = MonadState.lift vsTypes . (\bndr -> + mkMap = (\bndr -> let --info = Maybe.fromMaybe -- (error $ "Signal not found in the name map? This should not happen!") @@ -191,7 +197,7 @@ createArchitecture (fname, expr) = do procs = map mkStateProcSm [] -- (makeStatePairs flatfunc) procs' = map AST.CSPSm procs -- mkSigDec only uses vsTypes from the state - mkSigDec' = MonadState.lift vsTypes . mkSigDec + mkSigDec' = mkSigDec -- | Looks up all pairs of old state, new state signals, together with -- the state id they represent. @@ -220,7 +226,7 @@ mkStateProcSm (num, old, new) = rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)] statement = AST.IfSm rising_edge_clk [assign] [] Nothing -mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec) +mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec) mkSigDec bndr = if True then do --isInternalSigUse use || isStateSigUse use then do type_mark <- vhdl_ty $ Var.varType bndr @@ -243,25 +249,147 @@ mkConcSm :: mkConcSm (bndr, app@(CoreSyn.App _ _))= do signatures <- getA vsSignatures - let - (CoreSyn.Var f, args) = CoreSyn.collectArgs app - signature = Maybe.fromMaybe - (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") + funSignatures <- getA vsNameTable + let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + case (Map.lookup (bndrToString f) funSignatures) of + Just funSignature -> + let + sigs = map (bndrToString.varBndr) args + sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs + func = (snd funSignature) sigsNames + src_wform = AST.Wform [AST.WformElem func Nothing] + dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) + assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) + in + return $ AST.CSSASm assign + Nothing -> + let + signature = Maybe.fromMaybe + (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") (Map.lookup (bndrToString f) signatures) - entity_id = ent_id signature - label = bndrToString bndr + entity_id = ent_id signature + label = bndrToString bndr -- Add a clk port if we have state --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) - portmaps = mkAssocElems args bndr signature - in - return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) + portmaps = mkAssocElems args bndr signature + in + return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) -- GHC generates some funny "r = r" bindings in let statements before -- simplification. This outputs some dummy ConcSM for these, so things will at -- least compile for now. mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] [] +-- A single alt case must be a selector. This means thee scrutinee is a simple +-- variable, the alternative is a dataalt with a single non-wild binder that +-- is also returned. +mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = + case alt of + (DataAlt dc, bndrs, (Var sel_bndr)) -> do + case List.elemIndex sel_bndr bndrs of + Just i -> do + labels <- getFieldLabels (Id.idType scrut) + let label = labels!!i + let scrut_name = AST.NSimple $ bndrToVHDLId scrut + let sel_suffix = AST.SSimple $ label + let sel_name = AST.NSelected $ scrut_name AST.:.: sel_suffix + let sel_expr = AST.PrimName sel_name + return $ mkUncondAssign bndr sel_expr + Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr) + + _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr) + + +-- 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) + in + return $ mkCondAssign bndr cond_expr true_expr false_expr +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" + +-- Create an unconditional assignment statement +mkUncondAssign :: + CoreBndr -- ^ The signal to assign to + -> AST.Expr -- ^ The expression to assign + -> AST.ConcSm -- ^ The resulting concurrent statement +mkUncondAssign bndr expr = mkAssign bndr Nothing expr + +-- Create a conditional assignment statement +mkCondAssign :: + CoreBndr -- ^ The signal to assign to + -> AST.Expr -- ^ The condition + -> AST.Expr -- ^ The value when true + -> AST.Expr -- ^ The value when false + -> AST.ConcSm -- ^ The resulting concurrent statement +mkCondAssign bndr cond true false = mkAssign bndr (Just (cond, true)) false + +-- Create a conditional or unconditional assignment statement +mkAssign :: + CoreBndr -> -- ^ 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.ConcSm -- ^ The resulting concurrent statement + +mkAssign bndr cond false_expr = + let + -- I'm not 100% how this assignment AST works, but this gets us what we + -- want... + whenelse = case cond of + Just (cond_expr, true_expr) -> + let + true_wform = AST.Wform [AST.WformElem true_expr Nothing] + in + [AST.WhenElse true_wform cond_expr] + Nothing -> [] + false_wform = AST.Wform [AST.WformElem false_expr Nothing] + dst_name = AST.NSimple (bndrToVHDLId bndr) + assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing) + in + AST.CSSASm assign + +-- Finds the field labels for VHDL type generated for the given Core type, +-- which must result in a record type. +getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId] +getFieldLabels ty = do + -- Ensure that the type is generated (but throw away it's VHDLId) + vhdl_ty ty + -- Get the types map, lookup and unpack the VHDL TypeDef + types <- getA vsTypes + case Map.lookup (OrdType ty) types of + Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems + _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty) + +-- 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 @@ -281,7 +409,7 @@ mkConcSm sigs (UncondDef src dst) _ = do -- Create a cast expression, which is just a function call using the -- type name as the function name. let litexpr = AST.PrimLit lit - ty_id <- MonadState.lift vsTypes (vhdl_ty ty) + ty_id <- vhdl_ty ty let ty_name = AST.NSimple ty_id let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] return $ AST.PrimFCall $ AST.FCall ty_name args @@ -361,9 +489,9 @@ std_logic_ty :: AST.TypeMark std_logic_ty = AST.unsafeVHDLBasicId "std_logic" -- Translate a Haskell type to a VHDL type -vhdl_ty :: Type.Type -> TypeState AST.TypeMark +vhdl_ty :: Type.Type -> VHDLState AST.TypeMark vhdl_ty ty = do - typemap <- State.get + typemap <- getA vsTypes 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) @@ -375,24 +503,65 @@ vhdl_ty ty = do 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 - "FSVec" -> Just $ mk_vector_ty (fsvec_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 + -- Create a custom type from this tycon + otherwise -> mk_tycon_ty tycon args + Nothing -> return $ Nothing + +-- | Create VHDL type for a custom tycon +mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef)) +mk_tycon_ty tycon args = + case TyCon.tyConDataCons tycon of + -- Not an algebraic type + [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr 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 <- mapM vhdl_ty real_arg_tys + 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 ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) + let ty_def = AST.TDR $ AST.RecordTypeDef elems + return $ Just (ty_id, ty_def) + dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon) + 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) -- | 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 - -> TypeState 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 @@ -400,10 +569,8 @@ mk_vector_ty len ty = do -- 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)) - return ty_id + modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id)) + return (ty_id, ty_def) builtin_types = @@ -458,6 +625,10 @@ bndrToString :: bndrToString = OccName.occNameString . Name.nameOccName . Var.varName +-- Extracts the string version of the name +nameToString :: Name.Name -> String +nameToString = OccName.occNameString . Name.nameOccName + -- | A consise representation of a (set of) ports on a builtin function --type PortMap = HsValueMap (String, AST.TypeMark) -- | A consise representation of a builtin function @@ -480,6 +651,8 @@ builtin_funcs = mkBuiltins BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty) ] +recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] + -- | Map a port specification of a builtin function to a VHDL Signal to put in -- a VHDLSignalMap toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement