X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=4a62878af5f8756be751e2a9e28feeafe9496499;hb=4b87be0b9d499155084a6240b016afd57b4b30cd;hp=8dc7a0aaaef50b0dacc7bc0be63df0f0d5a28013;hpb=ec4378a8a765c5a064b5cbed347b40c353c778a0;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 8dc7a0a..4a62878 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -1,6 +1,6 @@ {-# LANGUAGE PackageImports #-} -module Generate where +module CLasH.VHDL.Generate where -- Standard modules import qualified Control.Monad as Monad @@ -26,11 +26,11 @@ import qualified Name import qualified TyCon -- Local imports -import Constants -import VHDLTypes -import VHDLTools -import CoreTools -import Pretty +import CLasH.VHDL.Constants +import CLasH.VHDL.VHDLTypes +import CLasH.VHDL.VHDLTools +import CLasH.Utils.Core.CoreTools +import CLasH.Utils.Pretty ----------------------------------------------------------------------------- -- Functions to generate VHDL for builtin functions @@ -161,6 +161,39 @@ genFromInteger' (Left res) f lits = do { genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name +genSizedInt :: BuiltinBuilder +genSizedInt = genFromInteger + +genTFVec :: BuiltinBuilder +genTFVec (Left res) f [Left veclist] = do { + ; let (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) = veclist + ; let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + ; let valargs = get_val_args (Var.varType f) args + ; apps <- genApplication (Left bndr) f (map Left valargs) + ; (aap,kooi) <- reduceFSVECListToHsList rez + ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndr:aap) + ; let vecsigns = concatsigs sigs + ; let vecassign = mkUncondAssign (Left res) vecsigns + ; sig_dec_maybes <- mapM mkSigDec (bndr:aap) + ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes) + ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndr:aap)))) + ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (apps ++ kooi ++ [vecassign]) + ; return $ [AST.CSBSm block] + } + where + concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x) + + +reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do + case letexpr of + (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) -> do + let (CoreSyn.Var f, args) = CoreSyn.collectArgs app + let valargs = get_val_args (Var.varType f) args + app <- genApplication (Left bndr) f (map Left valargs) + (vars, apps) <- reduceFSVECListToHsList rez + return ((bndr:vars),(app ++ apps)) + otherwise -> return ([],[]) + -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder @@ -248,7 +281,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) - let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start)) + let block_label = mkVHDLExtId ("foldlVector" ++ (varToString 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 @@ -549,6 +582,17 @@ genApplication dst f args = do let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in mkUncondAssign (Right sel_name) arg Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" + IdInfo.DataConWrapId dc -> case dst of + -- It's a datacon. Create a record from its arguments. + Left bndr -> do + case (Map.lookup (varToString f) globalNameTable) of + Just (arg_count, builder) -> + if length args == arg_count then + builder dst f args + else + error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc) + Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder" IdInfo.VanillaId -> do -- It's a global value imported from elsewhere. These can be builtin -- functions. Look up the function name in the name table and execute @@ -561,7 +605,7 @@ genApplication dst f args = do builder dst f args else error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f + Nothing -> return $ trace ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f)) [] IdInfo.ClassOpId cls -> do -- FIXME: Not looking for what instance this class op is called for -- Is quite stupid of course. @@ -609,10 +653,8 @@ genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements genUnconsVectorFuns elemTM vectorTM = [ (exId, (AST.SubProgBody exSpec [] [exExpr],[])) , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[])) - , (headId, (AST.SubProgBody headSpec [] [headExpr],[])) , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[])) , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[])) - , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[])) , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[])) , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[])) , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[])) @@ -658,7 +700,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1) @@ -667,23 +709,19 @@ genUnconsVectorFuns elemTM vectorTM = AST.PrimName (AST.NSimple aPar) AST.:&: vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1") ((AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)) AST.:-: AST.PrimLit "1")) replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) vecSlice init last = AST.PrimName (AST.NSlice (AST.SliceName (AST.NSimple vecPar) (AST.ToRange init last))) - headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM - -- return vec(0); - headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName - (AST.NSimple vecPar) [AST.PrimLit "0"]))) lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM -- return vec(vec'length-1); lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1"]))) initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-2); @@ -693,34 +731,16 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "2")) ])) Nothing -- resAST.:= vec(0 to vec'length-2) initExpr = AST.NSimple resId AST.:= (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "2")) initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) - tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM - -- variable res : fsvec_x (0 to vec'length-2); - tailVar = - AST.VarDec resId - (AST.SubtypeIn vectorTM - (Just $ AST.ConstraintIndex $ AST.IndexConstraint - [AST.ToRange (AST.PrimLit "0") - (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: - (AST.PrimLit "2")) ])) - Nothing - -- res AST.:= vec(1 to vec'length-1) - tailExpr = AST.NSimple resId AST.:= (vecSlice - (AST.PrimLit "1") - (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) - AST.:-: AST.PrimLit "1")) - tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM, AST.IfaceVarDec vecPar vectorTM ] vectorTM -- variable res : fsvec_x (0 to n-1); @@ -746,14 +766,14 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ])) Nothing -- res AST.:= vec(n to vec'length-1) dropExpr = AST.NSimple resId AST.:= (vecSlice (AST.PrimName $ AST.NSimple nPar) (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1")) dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM, @@ -765,7 +785,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))])) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))])) Nothing plusgtExpr = AST.NSimple resId AST.:= ((AST.PrimName $ AST.NSimple aPar) AST.:&: @@ -819,7 +839,7 @@ genUnconsVectorFuns elemTM vectorTM = -- for i res'range loop -- res(i) := vec(f+i*s); -- end loop; - selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign] + selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign] -- res(i) := vec(f+i*s); selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: (AST.PrimName (AST.NSimple iId) AST.:*: @@ -837,7 +857,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))])) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))])) Nothing ltplusExpr = AST.NSimple resId AST.:= ((AST.PrimName $ AST.NSimple vecPar) AST.:&: @@ -853,9 +873,9 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+: + AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+: AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1")])) Nothing plusplusExpr = AST.NSimple resId AST.:= @@ -864,7 +884,7 @@ genUnconsVectorFuns elemTM vectorTM = plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)) + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)) shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); @@ -874,7 +894,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res := a & init(vec) @@ -892,7 +912,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- res := tail(vec) & a @@ -906,7 +926,7 @@ genUnconsVectorFuns elemTM vectorTM = -- return vec'length = 0 nullExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=: AST.PrimLit "0") rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-1); @@ -916,7 +936,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- if null(vec) then res := vec else res := last(vec) & init(vec) @@ -940,7 +960,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- if null(vec) then res := vec else res := tail(vec) & head(vec) @@ -963,24 +983,25 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimName (AST.NAttribute $ - AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: (AST.PrimLit "1")) ])) Nothing -- for i in 0 to res'range loop -- res(vec'length-i-1) := vec(i); -- end loop; reverseFor = - AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign] + AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign] -- res(vec'length-i-1) := vec(i); reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:= (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $ AST.NSimple iId])) where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) - (mkVHDLBasicId lengthId) Nothing) AST.:-: + (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimName (AST.NSimple iId) AST.:-: (AST.PrimLit "1") -- return res; reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId)) + ----------------------------------------------------------------------------- -- A table of builtin functions @@ -1035,4 +1056,6 @@ globalNameTable = Map.fromList , (fromSizedWordId , (1, genFromSizedWord ) ) , (fromIntegerId , (1, genFromInteger ) ) , (resizeId , (1, genResize ) ) + , (sizedIntId , (1, genSizedInt ) ) + , (tfvecId , (1, genTFVec ) ) ]