X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=15eb4c59330327e7f82fac05e5aa4391c50b1fbe;hb=528eea4600faddffb577c6582a46c9732ab2679d;hp=84e4e379eabc6dce461728272a96ae0c41056d41;hpb=daba7a870fe4808faf6e54b26572a707237ec3c2;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index 84e4e37..15eb4c5 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -207,7 +207,8 @@ createArchitecture (fname, expr) = do sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds) let sig_decs = Maybe.catMaybes $ sig_dec_maybes - statements <- Monad.mapM mkConcSm binds + statementss <- Monad.mapM mkConcSm binds + let statements = concat statementss return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') where procs = map mkStateProcSm [] -- (makeStatePairs flatfunc) @@ -261,7 +262,12 @@ getSignalId info = -- | 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 instantiation. + -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations. + + +-- Ignore Cast expressions, they should not longer have any meaning as long as +-- the type works out. +mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) mkConcSm (bndr, app@(CoreSyn.App _ _))= do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app @@ -276,10 +282,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do --let valargs = filter isValArg args in if all is_var valargs then do labels <- getFieldLabels (CoreUtils.exprType app) - let assigns = zipWith mkassign labels valargs - let block_id = bndrToVHDLId bndr - let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns - return $ AST.CSBSm block + return $ zipWith mkassign labels valargs else error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args where @@ -295,14 +298,13 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do Just (arg_count, builder) -> if length valargs == arg_count then let - sigs = map (bndrToString.varBndr) valargs - sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs - func = builder sigsNames + sigs = map (varToVHDLExpr.varBndr) valargs + func = builder sigs 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 + return [AST.CSSASm assign] 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 @@ -315,20 +317,16 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") (Map.lookup f signatures) entity_id = ent_id signature - label = bndrToString bndr + label = "comp_ins_" ++ bndrToString 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 = mkAssocElems args bndr signature + portmaps = clk_port : mkAssocElems args bndr signature in - return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) + return [AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)] details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details --- 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. @@ -341,7 +339,7 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = let label = labels!!i let sel_name = mkSelectedName scrut label let sel_expr = AST.PrimName sel_name - return $ mkUncondAssign (Left bndr) sel_expr + return [mkUncondAssign (Left 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) @@ -352,11 +350,11 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = -- 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) + cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con) true_expr = (varToVHDLExpr true) false_expr = (varToVHDLExpr false) in - return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr + return [mkCondAssign (Left 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" mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr @@ -428,13 +426,26 @@ getFieldLabels ty = do -- 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 +varToVHDLExpr var = + case Id.isDataConWorkId_maybe var of + Just dc -> dataconToVHDLExpr dc + -- This is a dataconstructor. + -- Not a datacon, just another signal. Perhaps we should check for + -- local/global here as well? + Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var + +-- Turn a alternative 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. +altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr +altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc + +altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet" +altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!" + +-- Turn a datacon (without arguments!) into a VHDL expression. +dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr +dataconToVHDLExpr dc = AST.PrimLit lit where tycon = DataCon.dataConTyCon dc tyname = TyCon.tyConName tycon @@ -443,9 +454,6 @@ conToVHDLExpr (DataAlt dc) = AST.PrimLit lit -- 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!" - {-