(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)
-- Compare the (constructor field of the) scrutinee with each of the
-- alternatives.
let cond_exprs = map (\x -> cmp AST.:=: x) altcons
- -- Rotate expressions to the left, so that the expression related to the default case is the last
- exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) ((tail alts) ++ [head alts])
+ -- Rotate expressions to the leftso that the expression related to the default case is the last
+ -- Does NOT apply when there is no DEFAULT case and there are no binders
+ let alts' = if ((any (\(_,x,_) -> not (null x)) alts) || ((\(x,_,_)->x) (head alts)) == CoreSyn.DEFAULT ) then
+ ((tail alts) ++ [head alts])
+ else
+ alts
+ exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) alts' --((tail alts) ++ [head alts])
return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
"Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
"Index" -> do
bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
- return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
+ return $ (ceiling (logBase 2 (fromInteger (toInteger (bound)))))
let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
case args of
[integer] -> do -- The type and dictionary arguments are removed by genApplication
; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
; let res_type = (tfvec_elem . Var.varType) res
-- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
+ ; let { label = mkVHDLExtId ("mapVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
; let res_type = (tfvec_elem . Var.varType) res
-- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
+ ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (show vecExpr))
- let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToUniqString res))
let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
else AST.DownRange len_min_expr (AST.PrimLit "0")
let gen_scheme = AST.ForGn n_id gen_range
-- 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)
; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res))
; [AST.PrimName argName1, AST.PrimName argName2] <- argsToVHDLExprs [arg1,arg2]
-- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
+ ; let { label = mkVHDLExtId ("zipVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res)
; [AST.PrimName arg'] <- argsToVHDLExprs [arg]
-- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
+ ; let { label = mkVHDLExtId ("unzipVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
; [AST.PrimName argName] <- argsToVHDLExprs [arg]
-- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
+ ; let { label = mkVHDLExtId ("concatVector" ++ (varToUniqString res))
; n_id = mkVHDLBasicId "n"
; n_expr = idToVHDLExpr n_id
; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
-- Setup the generate scheme
[startExpr] <- argsToVHDLExprs [start]
let gen_label = mkVHDLExtId ("iterateVector" ++ (show startExpr))
- let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
+ let block_label = mkVHDLExtId ("iterateVector" ++ (varToUniqString res))
let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
let gen_scheme = AST.ForGn n_id gen_range
-- Make the intermediate vector
-- 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)
let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst rdaddr
let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
let assign = mkUncondAssign (Right resname) argexpr
- let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
+ let block_label = mkVHDLExtId ("blockRAM" ++ (varToUniqString res))
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
return [AST.CSBSm block]
where
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"))
]
projects / matthijs / master-project / cλash.git / blobdiff