(enums, cmp) <- case htype of
EnumType _ enums -> do
-- Enumeration type, compare with the scrutinee directly
- return (map stringToVHDLExpr enums, scrut_expr)
+ return (map (AST.PrimLit . show) [0..(length enums)-1], scrut_expr)
AggrType _ (Just (name, EnumType _ enums)) _ -> do
-- Extract the enumeration field from the aggregation
let sel_name = mkSelectedName (varToVHDLName scrut) (mkVHDLBasicId name)
let sel_expr = AST.PrimName sel_name
- return (map stringToVHDLExpr enums, sel_expr)
+ return (map (AST.PrimLit . show) [0..(length enums)-1], sel_expr)
(BuiltinType "Bit") -> do
let enums = [AST.PrimLit "'1'", AST.PrimLit "'0'"]
return (enums, scrut_expr)
-- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
- (app_concsms, used) <- genApplication (Right resname,res_type) (exprToVar folded_f) ( if left then
+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
+ let valargs = get_val_args (Var.varType real_f) already_mapped_args
+ (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
[(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
else
[(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
- )
+ ))
-- Return the conditional generate part
return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
- (app_concsms, used) <- genApplication (Right resname,res_type) (exprToVar folded_f) ( if left then
+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
+ let valargs = get_val_args (Var.varType real_f) already_mapped_args
+ (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
[(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
else
[(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
- )
+ ))
-- Return the conditional generate part
return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-- Input from start
[argexpr] <- argsToVHDLExprs [start]
let startassign = mkUncondAssign (Right resname) argexpr
- (app_concsms, used) <- genApplication (Right resname, res_type) (exprToVar app_f) [(Right argexpr, startType)]
+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
+ let valargs = get_val_args (Var.varType real_f) already_mapped_args
+ (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, startType)])
-- Return the conditional generate part
let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
[startassign]
let resname = mkIndexedName tmp_name n_cur
-- Input from tmp[previous n]
let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
- (app_concsms, used) <- genApplication (Right resname, res_type) (exprToVar app_f) [(Right argexpr, res_type)]
+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
+ let valargs = get_val_args (Var.varType real_f) already_mapped_args
+ (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, res_type)])
-- Return the conditional generate part
return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
where
vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
(AST.ToRange init last))
+
+genSll :: BuiltinBuilder
+genSll = genNoInsts $ genExprArgs $ genExprRes genSll'
+genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
+genSll' res f [(arg1,_),(arg2,_)] = do {
+ ; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
+ }
+
+genSra :: BuiltinBuilder
+genSra = genNoInsts $ genExprArgs $ genExprRes genSra'
+genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
+genSra' res f [(arg1,_),(arg2,_)] = do {
+ ; return $ (AST.Sra arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
+ }
+
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
-----------------------------------------------------------------------------
genApplication ::
- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
+ (Either CoreSyn.CoreBndr AST.VHDLName, Type.Type) -- ^ Where to store the result?
-> CoreSyn.CoreBndr -- ^ The function to apply
- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
+ -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The arguments to apply
-> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-- ^ The corresponding VHDL concurrent statements and entities
-- instantiated.
-genApplication dst f args = do
+genApplication (dst, dsttype) f args = do
nonemptydst <- case dst of
Left bndr -> hasNonEmptyType bndr
Right _ -> return True
then
if Var.isGlobalId f then
case Var.idDetails f of
- IdInfo.DataConWorkId dc -> case dst of
+ IdInfo.DataConWorkId dc -> do -- case dst of
-- It's a datacon. Create a record from its arguments.
- Left bndr -> do
+ --Left bndr -> do
-- We have the bndr, so we can get at the type
- htype_either <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
- let argsNoState = filter (\x -> not (either hasStateType (\x -> False) x)) args
- let dcs = datacons_for bndr
+ htype_either <- MonadState.lift tsType $ mkHTypeEither dsttype
+ let argsNoState = filter (\x -> not (either hasStateType (\x -> False) x)) (map fst args)
+ let dcs = datacons_for dsttype
case (dcs, argsNoState) of
-- This is a type with a single datacon and a single
-- argument, so no record is created (the type of the
return ([mkUncondAssign dst arg'], [])
-- In all other cases, a record type is created.
_ -> case htype_either of
- Right htype@(AggrType _ _ _) -> do
- let dc_i = datacon_index (Var.varType bndr) dc
+ Right htype@(AggrType _ etype _) -> do
+ let dc_i = datacon_index dsttype dc
let labels = getFieldLabels htype dc_i
arg_exprs <- argsToVHDLExprs argsNoState
let (final_labels, final_exprs) = case getConstructorFieldLabel htype of
-- constructor used to the constructor field as
-- well.
Just dc_label ->
- let dc_expr = AST.PrimName $ AST.NSimple $ mkVHDLExtId $ varToString f in
- (dc_label:labels, dc_expr:arg_exprs)
+ let { dc_index = getConstructorIndex (snd $ Maybe.fromJust etype) (varToString f)
+ ; dc_expr = AST.PrimLit $ show dc_index
+ } in (dc_label:labels, dc_expr:arg_exprs)
return (zipWith mkassign final_labels final_exprs, [])
where
mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
simple_assign = do
expr <- MonadState.lift tsType $ dataconToVHDLExpr dc
return ([mkUncondAssign dst expr], [])
-
- Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
+ --
+ -- Right _ -> do
+ -- let dcs = datacons_for dsttype
+ -- error $ "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" ++ show dcs
IdInfo.DataConWrapId dc -> case dst of
-- It's a datacon. Create a record from its arguments.
Left bndr ->
-- Local binder that references a top level binding. Generate a
-- component instantiation.
signature <- getEntity f
- args' <- argsToVHDLExprs args
+ args' <- argsToVHDLExprs (map fst args)
let entity_id = ent_id signature
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
-- Local binder that references a top level binding. Generate a
-- component instantiation.
signature <- getEntity f
- args' <- argsToVHDLExprs args
+ args' <- argsToVHDLExprs (map fst args)
let entity_id = ent_id signature
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
, (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
, (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
, (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
- , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
- , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
+ , (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
+ , (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
, (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
, (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
, (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
- shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
+ shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
shiftlVar =
(AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
[Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
+ shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM,
AST.IfaceVarDec aPar elemTM ] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
shiftrVar =
, (foldrId , (3, genFoldr ) )
, (zipId , (2, genZip ) )
, (unzipId , (1, genUnzip ) )
- , (shiftlId , (2, genFCall False ) )
- , (shiftrId , (2, genFCall False ) )
+ , (shiftIntoLId , (2, genFCall False ) )
+ , (shiftIntoRId , (2, genFCall False ) )
, (rotlId , (1, genFCall False ) )
, (rotrId , (1, genFCall False ) )
, (concatId , (1, genConcat ) )
, (sndId , (1, genSnd ) )
, (blockRAMId , (5, genBlockRAM ) )
, (splitId , (1, genSplit ) )
+ , (xorId , (2, genOperator2 AST.Xor ) )
+ , (shiftLId , (2, genSll ) )
+ , (shiftRId , (2, genSra ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
]