X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=dad3aec2623867ec0c958a3810ac9ca5ff35ce34;hb=e03f02c419b4365d498c25dfbc861215394046df;hp=d177a10b934dc8004425a150552de5df83c12e4e;hpb=e230d86ae7135a268a72cdffba947a9011001ec2;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index d177a10..dad3aec 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -22,12 +22,14 @@ 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 TyCon -import qualified CoreSyn +import qualified DataCon +import qualified CoreSubst import Outputable ( showSDoc, ppr ) -- Local imports @@ -54,7 +56,7 @@ createDesignFiles binds = 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"], @@ -63,7 +65,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 @@ -246,25 +248,82 @@ 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 +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 @@ -378,24 +437,35 @@ 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 - "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 @@ -403,12 +473,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)) - 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 =