X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=96a541ee0e36f04a1ac27232aeca6e496e005711;hb=130e806e04ceecd8d209f801891d2b1a32fa144e;hp=e4ab534e1f16b31bfe99e306402e71a28881f4ec;hpb=8d85e188a160026009f40a11a1364a7c74f58b60;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index e4ab534..96a541e 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -28,6 +28,7 @@ import qualified Name import qualified OccName import qualified Var import qualified Id +import qualified IdInfo import qualified TyCon import qualified DataCon import qualified CoreSubst @@ -248,33 +249,41 @@ mkConcSm :: -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation. mkConcSm (bndr, app@(CoreSyn.App _ _))= do - signatures <- getA vsSignatures - 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 -> + case Var.globalIdVarDetails f of + IdInfo.VanillaGlobal -> do + -- It's a global value imported from elsewhere. These can be builting + -- functions. + funSignatures <- getA vsNameTable + 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 -> 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 '" ++ (bndrToString f) ++ "' without signature? This should not happen!") (Map.lookup (bndrToString f) signatures) 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 []) + -- 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) + in + 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 @@ -291,20 +300,13 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = 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_name = mkSelectedName scrut label let sel_expr = AST.PrimName sel_name - let sel_wform = AST.Wform [AST.WformElem sel_expr Nothing] - let dst_name = AST.NSimple (bndrToVHDLId bndr) - -- TODO: Reduce code duplication with the next mkConcSm clause - let assign = dst_name AST.:<==: (AST.ConWforms [] sel_wform Nothing) - return $ AST.CSSASm assign + 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) - -- 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 @@ -314,16 +316,64 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) 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 + 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" +-- Create an unconditional assignment statement +mkUncondAssign :: + Either CoreBndr AST.VHDLName -- ^ The signal to assign to + -> AST.Expr -- ^ The expression to assign + -> AST.ConcSm -- ^ The resulting concurrent statement +mkUncondAssign dst expr = mkAssign dst Nothing expr + +-- Create a conditional assignment statement +mkCondAssign :: + Either CoreBndr AST.VHDLName -- ^ 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 dst cond true false = mkAssign dst (Just (cond, true)) false + +-- Create a conditional or unconditional assignment statement +mkAssign :: + Either CoreBndr AST.VHDLName -> -- ^ 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 dst 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 = case dst of + Left bndr -> AST.NSimple (bndrToVHDLId bndr) + Right name -> name + assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing) + in + AST.CSSASm assign + +-- Create a record field selector that selects the given label from the record +-- stored in the given binder. +mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName +mkSelectedName bndr label = + let + sel_prefix = AST.NSimple $ bndrToVHDLId bndr + sel_suffix = AST.SSimple $ label + in + AST.NSelected $ sel_prefix AST.:.: sel_suffix + -- 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]