X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=8eb130fad8e0d11e016e3222e011f55b36977e05;hb=8a17f35807fb35ee4d2a4c35c75e1cf99066f94d;hp=76102315a4a186208f20dcd6543d20c8c323be16;hpb=eb3177ed5e53fd27bc64a45584ab646545c27e5f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index 7610231..8eb130f 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -39,6 +39,9 @@ import TranslatorTypes import HsValueMap import Pretty import CoreTools +import Constants +import Generate +import GlobalNameTable createDesignFiles :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] @@ -49,7 +52,7 @@ 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) @@ -110,7 +113,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!") @@ -192,7 +195,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. @@ -221,7 +224,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 @@ -244,19 +247,32 @@ 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 @@ -326,7 +342,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 @@ -406,9 +422,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) @@ -425,7 +441,7 @@ vhdl_ty ty = do (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 + "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 @@ -437,7 +453,7 @@ vhdl_ty ty = do 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 -- The typemark created. mk_vector_ty len ty = do -- Assume there is a single type argument @@ -447,7 +463,9 @@ mk_vector_ty len ty = do 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)) + --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