getEntity fname = Utils.makeCached fname tsEntities $ do
expr <- Normalize.getNormalized fname
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
+ -- Split the normalized expression
+ let (args, binds, res) = Normalize.splitNormalized expr
-- Generate ports for all non-empty types
args' <- catMaybesM $ mapM mkMap args
- -- There must be a let at top level
- let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
-- TODO: Handle Nothing
res' <- mkMap res
- let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
+ count <- getA tsEntityCounter
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
+ putA tsEntityCounter (count + 1)
let ent_decl = createEntityAST vhdl_id args' res'
let signature = Entity vhdl_id args' res' ent_decl
return signature
getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
expr <- Normalize.getNormalized fname
+ -- Split the normalized expression
+ let (args, binds, res) = Normalize.splitNormalized expr
+
+ -- Get the entity for this function
signature <- getEntity fname
let entity_id = ent_id signature
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- -- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr
-- Create signal declarations for all binders in the let expression, except
-- for the output port (that will already have an output port declared in
let (in_state_maybes, out_state_maybes) = unzip state_vars
let (statementss, used_entitiess) = unzip sms
-- Create a state proc, if needed
- let state_proc = case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
- ([in_state], [out_state]) -> [AST.CSPSm $ mkStateProcSm (in_state, out_state)]
- ([], []) -> []
+ state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
+ ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
+ ([], []) -> return []
(ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
-- Join the create statements and the (optional) state_proc
let statements = concat statementss ++ state_proc
mkStateProcSm ::
(CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
- -> AST.ProcSm -- ^ The resulting statement
-mkStateProcSm (old, new) =
- AST.ProcSm label [clk] [statement]
+ -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
+mkStateProcSm (old, new) = do
+ nonempty <- hasNonEmptyType old
+ if nonempty
+ then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
+ else return []
where
label = mkVHDLBasicId $ "state"
clk = mkVHDLBasicId "clock"
-- Return the generate functions
; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
}
+
+-- | Generate a generate statement for the builtin function "fst"
+genFst :: BuiltinBuilder
+genFst = genNoInsts $ genVarArgs genFst'
+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genFst' (Left res) f args@[arg] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
+ ; let { argexpr' = varToVHDLName arg
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
+ ; assign = mkUncondAssign (Left res) argexprA
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
+
+-- | Generate a generate statement for the builtin function "snd"
+genSnd :: BuiltinBuilder
+genSnd = genNoInsts $ genVarArgs genSnd'
+genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSnd' (Left res) f args@[arg] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
+ ; let { argexpr' = varToVHDLName arg
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
+ ; assign = mkUncondAssign (Left res) argexprB
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
-- | Generate a generate statement for the builtin function "unzip"
genUnzip :: BuiltinBuilder
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
let label = "comp_ins_" ++ (either show prettyShow) dst
- portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
return ([mkComponentInst label entity_id portmaps], [f])
False -> do
-- Not a top level binder, so this must be a local variable reference.
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
let label = "comp_ins_" ++ (either show prettyShow) dst
- portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
return ([mkComponentInst label entity_id portmaps], [f])
False -> do
-- Not a top level binder, so this must be a local variable reference.
, (hwandId , (2, genOperator2 AST.And ) )
, (hworId , (2, genOperator2 AST.Or ) )
, (hwnotId , (1, genOperator1 AST.Not ) )
+ , (equalityId , (2, genOperator2 (AST.:=:) ) )
+ , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
+ , (boolOrId , (2, genOperator2 AST.Or ) )
+ , (boolAndId , (2, genOperator2 AST.And ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
, (timesId , (2, genOperator2 (AST.:*:) ) )
, (negateId , (1, genNegation ) )
, (resizeId , (1, genResize ) )
, (sizedIntId , (1, genSizedInt ) )
, (smallIntegerId , (1, genFromInteger ) )
+ , (fstId , (1, genFst ) )
+ , (sndId , (1, genSnd ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
]