X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=5618532c2f1771fd18d88ba417120072e94206fb;hb=68452976b782fcf291a678330ca3a9703e8c7c35;hp=e5d6bf5e18086bb96e7261bca829202b69767b24;hpb=28fc9c7226af6124a2c72c1f23c8e1b6cf196e18;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 e5d6bf5..5618532 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -1,14 +1,9 @@ -{-# LANGUAGE PackageImports #-} - module CLasH.VHDL.Generate where -- Standard modules -import qualified Control.Monad as Monad import qualified Data.Map as Map import qualified Maybe import qualified Data.Either as Either -import qualified Control.Monad.Trans.State as State -import qualified "transformers" Control.Monad.Identity as Identity import Data.Accessor import Data.Accessor.MonadState as MonadState import Debug.Trace @@ -17,8 +12,8 @@ import Debug.Trace import qualified Language.VHDL.AST as AST -- GHC API -import CoreSyn -import Type +import qualified CoreSyn +import qualified Type import qualified Var import qualified IdInfo import qualified Literal @@ -151,12 +146,17 @@ genFromInteger' (Left res) f lits = do { ; (tycon, args) = Type.splitTyConApp ty ; name = Name.getOccString (TyCon.tyConName tycon) } ; - ; len <- case name of - "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty) - "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty) - ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId - ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) - [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))] + ; case name of + "RangedWord" -> return $ AST.PrimLit (show (last lits)) + otherwise -> do { + ; len <- case name of + "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty) + "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty) + "RangedWord" -> MonadState.lift vsType $ tfp_to_int (ranged_word_bound_ty ty) + ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId + ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) + [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))] + } } genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name @@ -164,48 +164,79 @@ genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot g genSizedInt :: BuiltinBuilder genSizedInt = genFromInteger +-- | Generate a Builder for the builtin datacon TFVec genTFVec :: BuiltinBuilder -genTFVec (Left res) f [Left veclist] = do { - ; let (CoreSyn.Let (CoreSyn.Rec letbndrs) rez) = trace ("\n***\n" ++ show veclist ++ "\n**\n" ++ pprString veclist ++ "\n***\n") veclist - ; letapps <- mapM genLetApp letbndrs - ; let bndrs = Maybe.catMaybes (map fst letapps) - ; (aap,kooi) <- reduceFSVECListToHsList rez - ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndrs ++ aap) - ; let vecsigns = concatsigs sigs - ; let vecassign = mkUncondAssign (Left res) vecsigns - ; sig_dec_maybes <- mapM mkSigDec (bndrs ++ aap) - ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes) - ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndrs ++ aap)))) - ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letapps)) ++ kooi ++ [vecassign]) +genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do { + -- Generate Assignments for all the binders + ; letAssigns <- mapM genBinderAssign letBinders + -- Generate assignments for the result (which might be another let binding) + ; (resBinders,resAssignments) <- genResAssign letRes + -- Get all the Assigned binders + ; let assignedBinders = Maybe.catMaybes (map fst letAssigns) + -- Make signal names for all the assigned binders + ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders) + -- Assign all the signals to the resulting vector + ; let { vecsigns = mkAggregateSignal sigs + ; vecassign = mkUncondAssign (Left res) vecsigns + } ; + -- Generate all the signal declaration for the assigned binders + ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders) + ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes) + -- Setup the VHDL Block + ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res)) + ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign]) + } ; + -- Return the block statement coressponding to the TFVec literal ; return $ [AST.CSBSm block] } where - concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x) + genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm]) + -- For now we only translate applications + genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do + 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) + return (Just bndr, apps) + genBinderAssign _ = return (Nothing,[]) + genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm]) + genResAssign app@(CoreSyn.App _ letexpr) = do + case letexpr of + (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do + letapps <- mapM genBinderAssign letbndrs + let bndrs = Maybe.catMaybes (map fst letapps) + let app = (map snd letapps) + (vars, apps) <- genResAssign letres + return ((bndrs ++ vars),((concat app) ++ apps)) + otherwise -> return ([],[]) + genResAssign _ = return ([],[]) -genLetApp :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm]) -genLetApp (bndr, app@(CoreSyn.App _ _)) = do - 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) - return (Just bndr, apps) +genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do { + ; let { elems = reduceCoreListToHsList app + -- Make signal names for all the binders + ; binders = map (\expr -> case expr of + (CoreSyn.Var b) -> b + otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: " + ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems + } ; + ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders + -- Assign all the signals to the resulting vector + ; let { vecsigns = mkAggregateSignal sigs + ; vecassign = mkUncondAssign (Left res) vecsigns + -- Setup the VHDL Block + ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res)) + ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign] + } ; + -- Return the block statement coressponding to the TFVec literal + ; return $ [AST.CSBSm block] + } -genLetApp _ = return (Nothing,[]) - -reduceFSVECListToHsList :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm]) -reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do - case letexpr of - (CoreSyn.Let (CoreSyn.Rec letbndrs) rez) -> do - letapps <- mapM genLetApp letbndrs - let bndrs = Maybe.catMaybes (map fst letapps) - let app = (map snd letapps) - (vars, apps) <- reduceFSVECListToHsList rez - return ((bndrs ++ vars),((concat app) ++ apps)) - otherwise -> return ([],[]) +genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs +genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder -genMap (Left res) f [Left mapped_f, Left (Var arg)] = do { +genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do { -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since -- we must index it (which we couldn't if it was a VHDL Expr, since only @@ -281,7 +312,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do -- An expression for len-1 let len_min_expr = (AST.PrimLit $ show (len-1)) -- evec is (TFVec n), so it still needs an element type - let (nvec, _) = splitAppTy (Var.varType vec) + let (nvec, _) = Type.splitAppTy (Var.varType vec) -- Put the type of the start value in nvec, this will be the type of our -- temporary vector let tmp_ty = Type.mkAppTy nvec (Var.varType start) @@ -429,7 +460,7 @@ genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var genConcat' (Left res) f args@[arg] = do { -- Setup the generate scheme ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg - ; let (_, nvec) = splitAppTy (Var.varType arg) + ; let (_, nvec) = Type.splitAppTy (Var.varType arg) ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec -- TODO: Use something better than varToString ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res)) @@ -613,7 +644,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 -> return $ trace ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f)) [] + Nothing -> error $ ("\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. @@ -663,7 +694,8 @@ genUnconsVectorFuns elemTM vectorTM = , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[])) , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[])) , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[])) - , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[])) + , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[])) + , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId])) , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[])) , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[])) , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[])) @@ -686,12 +718,14 @@ genUnconsVectorFuns elemTM vectorTM = vec1Par = AST.unsafeVHDLBasicId "vec1" vec2Par = AST.unsafeVHDLBasicId "vec2" nPar = AST.unsafeVHDLBasicId "n" + leftPar = AST.unsafeVHDLBasicId "nLeft" + rightPar = AST.unsafeVHDLBasicId "nRight" iId = AST.unsafeVHDLBasicId "i" iPar = iId aPar = AST.unsafeVHDLBasicId "a" fPar = AST.unsafeVHDLBasicId "f" sPar = AST.unsafeVHDLBasicId "s" - resId = AST.unsafeVHDLBasicId "res" + resId = AST.unsafeVHDLBasicId "res" exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec ixPar naturalTM] elemTM exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed @@ -749,21 +783,32 @@ genUnconsVectorFuns elemTM vectorTM = AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "2")) initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) + minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM, + AST.IfaceVarDec rightPar naturalTM ] naturalTM + minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar)) + [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)] + [] + (Just $ AST.Else [minimumExprRet]) + where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar) takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM, AST.IfaceVarDec vecPar vectorTM ] vectorTM - -- variable res : fsvec_x (0 to n-1); + -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1); + minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId)) + [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar) + ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $ + AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))] takeVar = AST.VarDec resId (AST.SubtypeIn vectorTM (Just $ AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") - ((AST.PrimName (AST.NSimple nPar)) AST.:-: + (minLength AST.:-: (AST.PrimLit "1")) ])) Nothing -- res AST.:= vec(0 to n-1) takeExpr = AST.NSimple resId AST.:= - (vecSlice (AST.PrimLit "1") - (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1")) + (vecSlice (AST.PrimLit "0") + (minLength AST.:-: AST.PrimLit "1")) takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM, AST.IfaceVarDec vecPar vectorTM ] vectorTM @@ -1019,7 +1064,7 @@ genUnconsVectorFuns elemTM vectorTM = -- builder function. globalNameTable :: NameTable globalNameTable = Map.fromList - [ (exId , (2, genFCall False ) ) + [ (exId , (2, genFCall True ) ) , (replaceId , (3, genFCall False ) ) , (headId , (1, genFCall True ) ) , (lastId , (1, genFCall True ) ) @@ -1066,4 +1111,5 @@ globalNameTable = Map.fromList , (resizeId , (1, genResize ) ) , (sizedIntId , (1, genSizedInt ) ) , (tfvecId , (1, genTFVec ) ) + , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name")) ]