-{-# LANGUAGE PackageImports #-}
-
-module Generate where
+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
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
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
genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genSizedInt :: BuiltinBuilder
+genSizedInt = genFromInteger
+
+-- | Generate a Builder for the builtin datacon TFVec
+genTFVec :: BuiltinBuilder
+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
+ 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 ([],[])
+
+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]
+ }
+
+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
-- 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)
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
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))
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
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 -> 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.
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],[]))
(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)
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);
(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);
(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,
(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.:&:
-- 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.:*:
(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.:&:
(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.:=
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);
(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)
(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
-- 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);
(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)
(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)
(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
, (fromSizedWordId , (1, genFromSizedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeId , (1, genResize ) )
+ , (sizedIntId , (1, genSizedInt ) )
+ , (tfvecId , (1, genTFVec ) )
]
projects / matthijs / master-project / cλash.git / blobdiff