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
-- the entity).
- sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
+ sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
let sig_decs = Maybe.catMaybes $ sig_dec_maybes
-
- (statementss, used_entitiess) <- Monad.mapAndUnzipM mkConcSm binds
- let statements = concat statementss
+ -- Process each bind, resulting in info about state variables and concurrent
+ -- statements.
+ (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
+ let (in_state_maybes, out_state_maybes) = unzip state_vars
+ let (statementss, used_entitiess) = unzip sms
+ -- Create a state proc, if needed
+ 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
+ -- Create the architecture
+ let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
let used_entities = concat used_entitiess
- let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
return (arch, used_entities)
where
- procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
- procs' = map AST.CSPSm procs
- -- mkSigDec only uses tsTypes from the state
- mkSigDec' = mkSigDec
+ dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
+ -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
+ -- ^ ((Input state variable, output state variable), (statements, used entities))
+ -- newtype unpacking is just a cast
+ dobind (bndr, (CoreSyn.Cast expr coercion))
+ | hasStateType expr
+ = return ((Just bndr, Nothing), ([], []))
+ -- With simplCore, newtype packing is just a cast
+ dobind (bndr, expr@(CoreSyn.Cast (CoreSyn.Var state) coercion))
+ | hasStateType expr
+ = return ((Nothing, Just state), ([], []))
+ -- Without simplCore, newtype packing uses a data constructor
+ dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
+ | isStateCon con
+ = return ((Nothing, Just state), ([], []))
+ -- Anything else is handled by mkConcSm
+ dobind bind = do
+ sms <- mkConcSm bind
+ return ((Nothing, Nothing), sms)
+
+mkStateProcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
+ -> 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"
+ rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+ wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
+ assign = AST.SigAssign (varToVHDLName old) wform
+ rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
+ statement = AST.IfSm rising_edge_clk [assign] [] Nothing
+
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
-- 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.
-- assignment here.
f' <- MonadState.lift tsType $ varToVHDLExpr f
return $ ([mkUncondAssign dst f'], [])
- True | not stateful ->
+ True ->
case Var.idDetails f of
IdInfo.DataConWorkId dc -> case dst of
-- It's a datacon. Create a record from its arguments.
-- 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.
error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
- -- If we can't generate a component instantiation, and the destination is
- -- a state type, don't generate anything.
- _ -> return ([], [])
- where
- -- Is our destination a state value?
- stateful = case dst of
- -- When our destination is a VHDL name, it won't have had a state type
- Right _ -> False
- -- Otherwise check its type
- Left bndr -> hasStateType bndr
-----------------------------------------------------------------------------
-- Functions to generate functions dealing with vectors.
, (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"))
]
projects / matthijs / master-project / cλash.git / blobdiff