X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=c646f8b52858f210ea7b69fd816c082c8a03c9a4;hb=969b7ddd86b69d2fc61b101961affcca0364749c;hp=da35a9018b9de03665f8f19fedb12a740d504210;hpb=597f1b6823417f2c4cc54549f2a9d1b9f131893c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index da35a90..c646f8b 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -12,6 +12,7 @@ import qualified Control.Arrow as Arrow import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid import Data.Accessor +import Debug.Trace -- ForSyDe import qualified ForSyDe.Backend.VHDL.AST as AST @@ -36,7 +37,6 @@ import Pretty import CoreTools import Constants import Generate -import GlobalNameTable createDesignFiles :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] @@ -47,10 +47,10 @@ createDesignFiles binds = map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable + init_session = VHDLState Map.empty Map.empty Map.empty Map.empty (units, final_session) = State.runState (createLibraryUnits binds) init_session - tyfun_decls = Map.elems (final_session ^.vsTypeFuns) + tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns) ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes) vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes)) tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def @@ -66,9 +66,9 @@ createDesignFiles binds = : (mkUseAll ["work"] : ieee_context) type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs) - type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls) - subProgSpecs = concat (map subProgSpec tyfun_decls) - subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) + type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls + subProgSpecs = map subProgSpec tyfun_decls + subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def @@ -85,7 +85,7 @@ mkUseAll ss = createLibraryUnits :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] - -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])] + -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])] createLibraryUnits binds = do entities <- Monad.mapM createEntity binds @@ -100,7 +100,7 @@ createLibraryUnits binds = do -- | Create an entity for a given function createEntity :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function - -> VHDLState AST.EntityDec -- | The resulting entity + -> VHDLSession AST.EntityDec -- | The resulting entity createEntity (fname, expr) = do -- Strip off lambda's, these will be arguments @@ -119,7 +119,7 @@ createEntity (fname, expr) = do mkMap :: --[(SignalId, SignalInfo)] CoreSyn.CoreBndr - -> VHDLState VHDLSignalMapElement + -> VHDLSession VHDLSignalMapElement -- We only need the vsTypes element from the state mkMap = (\bndr -> let @@ -181,7 +181,7 @@ mkEntityId hsfunc = -- | Create an architecture for a given function createArchitecture :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function - -> VHDLState AST.ArchBody -- ^ The architecture for this function + -> VHDLSession AST.ArchBody -- ^ The architecture for this function createArchitecture (fname, expr) = do signaturemap <- getA vsSignatures @@ -246,7 +246,7 @@ getSignalId info = (sigName info) -} -mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec) +mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) mkSigDec bndr = if True then do --isInternalSigUse use || isStateSigUse use then do type_mark <- vhdl_ty $ Var.varType bndr @@ -257,7 +257,7 @@ mkSigDec bndr = -- | Transforms a core binding into a VHDL concurrent statement mkConcSm :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process - -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. + -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. -- Ignore Cast expressions, they should not longer have any meaning as long as @@ -274,71 +274,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app let valargs' = filter isValArg args let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs' - case Var.globalIdVarDetails f of - IdInfo.DataConWorkId dc -> - -- It's a datacon. Create a record from its arguments. - -- First, filter out type args. TODO: Is this the best way to do this? - -- The types should already have been taken into acocunt when creating - -- the signal, so this should probably work... - --let valargs = filter isValArg args in - if all is_var valargs then do - labels <- getFieldLabels (CoreUtils.exprType app) - return $ zipWith mkassign labels valargs - else - error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args - where - mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm - mkassign label (Var arg) = - let sel_name = mkSelectedName bndr label in - mkUncondAssign (Right sel_name) (varToVHDLExpr arg) - IdInfo.VanillaGlobal -> do - -- It's a global value imported from elsewhere. These can be builtin - -- functions. - funSignatures <- getA vsNameTable - signatures <- getA vsSignatures - case (Map.lookup (varToString f) funSignatures) of - Just (arg_count, builder) -> - if length valargs == arg_count then - case builder of - Left funBuilder -> - let - sigs = map (varToVHDLExpr.exprToVar) valargs - func = funBuilder sigs - src_wform = AST.Wform [AST.WformElem func Nothing] - dst_name = AST.NSimple (mkVHDLExtId (varToString bndr)) - assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) - in - return [AST.CSSASm assign] - Right genBuilder -> - let - sigs = map exprToVar valargs - signature = Maybe.fromMaybe - (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!") - (Map.lookup (head sigs) signatures) - arg = tail sigs - genSm = genBuilder signature (arg ++ [bndr]) - in return [AST.CSGSm genSm] - else - error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs - Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f - IdInfo.NotGlobalId -> do - signatures <- getA vsSignatures - -- This is a local id, so it should be a function whose definition we - -- have and which can be turned into a component instantiation. - let - signature = Maybe.fromMaybe - (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") - (Map.lookup f signatures) - entity_id = ent_id signature - label = "comp_ins_" ++ varToString bndr - -- Add a clk port if we have state - --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" - clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk" - --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) - portmaps = clk_port : mkAssocElems args bndr signature - in - return [mkComponentInst label entity_id portmaps] - details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details + genApplication (Left bndr) f (map Left valargs) -- 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 @@ -350,7 +286,7 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = Just i -> do labels <- getFieldLabels (Id.idType scrut) let label = labels!!i - let sel_name = mkSelectedName scrut label + let sel_name = mkSelectedName (varToVHDLName scrut) label let sel_expr = AST.PrimName sel_name return [mkUncondAssign (Left bndr) sel_expr] Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)