(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
; 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
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
-----------------------------------------------------------------------------
return ([mkUncondAssign dst arg'], [])
-- In all other cases, a record type is created.
_ -> case htype_either of
- Right htype@(AggrType _ _ _) -> do
+ Right htype@(AggrType _ etype _) -> do
let dc_i = datacon_index dsttype dc
let labels = getFieldLabels htype dc_i
arg_exprs <- argsToVHDLExprs argsNoState
-- 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
, (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