X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;ds=sidebyside;f=clash%2FCLasH%2FVHDL%2FGenerate.hs;h=8c59334085fe6e53bcd153eb514320e96b2a67d0;hb=30969fa41ee30295f00cf089f4ee4385bb709871;hp=da078f7873ff203f25e353ea6e72c7310b728fc2;hpb=8dbc46595b3e05117b361eeb1babc0b1f033dbb6;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/clash/CLasH/VHDL/Generate.hs b/clash/CLasH/VHDL/Generate.hs index da078f7..8c59334 100644 --- a/clash/CLasH/VHDL/Generate.hs +++ b/clash/CLasH/VHDL/Generate.hs @@ -714,11 +714,13 @@ genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecTy -- 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) @@ -736,11 +738,13 @@ genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecTy 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) @@ -969,7 +973,9 @@ genIterateOrGenerate' len iter (Left res) f [(Left app_f,_), (start,startType)] -- 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] @@ -987,7 +993,9 @@ genIterateOrGenerate' len iter (Left res) f [(Left app_f,_), (start,startType)] 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) @@ -1056,17 +1064,32 @@ genSplit' (Left res) f args@[(vecIn,vecInType)] = do { 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 @@ -1074,13 +1097,13 @@ genApplication dst f args = do 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 @@ -1091,7 +1114,7 @@ genApplication dst f args = do -- 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 + 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 @@ -1125,8 +1148,10 @@ genApplication dst f args = do 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 -> @@ -1157,7 +1182,7 @@ genApplication dst f args = do -- 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... @@ -1196,7 +1221,7 @@ genApplication dst f args = do -- 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... @@ -1265,8 +1290,8 @@ genUnconsVectorFuns elemTM vectorTM = , (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])) @@ -1494,7 +1519,7 @@ genUnconsVectorFuns elemTM vectorTM = 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 = @@ -1512,7 +1537,7 @@ genUnconsVectorFuns elemTM vectorTM = (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 = @@ -1652,8 +1677,8 @@ globalNameTable = Map.fromList , (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 ) ) @@ -1696,6 +1721,9 @@ globalNameTable = Map.fromList , (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")) ]