{-# LANGUAGE TemplateHaskell, TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : ForSyDe.Deep.Backend.VHDL.Traverse -- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : forsyde-dev@ict.kth.se -- Stability : experimental -- Portability : portable -- -- Functions to translate elements of the intermediate system -- representation to elements of the VHDL AST. ----------------------------------------------------------------------------- module ForSyDe.Deep.Backend.VHDL.Translate where import ForSyDe.Deep.Backend.VHDL.AST import qualified ForSyDe.Deep.Backend.VHDL.AST as VHDL import ForSyDe.Deep.Backend.VHDL.Constants import ForSyDe.Deep.Backend.VHDL.Generate import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM import ForSyDe.Deep.Backend.VHDL.Translate.HigherOrderFunctions import ForSyDe.Deep.Ids import ForSyDe.Deep.AbsentExt import ForSyDe.Deep.Signal import ForSyDe.Deep.Bit hiding (not) import ForSyDe.Deep.ForSyDeErr import ForSyDe.Deep.System.SysDef import ForSyDe.Deep.Process.ProcFun import ForSyDe.Deep.Process.ProcVal import ForSyDe.Deep.Process.ProcType import Data.Data (tyconUQname) import Data.Int import Data.Char (digitToInt) import Data.List (intersperse) import Data.Maybe (isJust, fromJust) import Control.Monad.State import qualified Data.Set as S import qualified Language.Haskell.TH as TH import Language.Haskell.TH hiding (global,Loc) import qualified Data.Traversable as DT import Data.Typeable import Data.Typeable.Internal import qualified Data.Param.FSVec as V import Text.Regex.Posix ((=~)) import Data.TypeLevel.Num.Reps import Data.Typeable.FSDTypeRepLib -- enable tracing of type translation -- import Debug.Trace debug :: a -> String -> a -- debug = flip trace debug a _ = a -- | Translate a System Definition to an Entity, explicitly returning -- the VHDL identifiers of its output signals. transSysDef2Ent :: SysLogic -- ^ logic of the system -> SysDefVal -- ^ system to translate -> VHDLM EntityDec transSysDef2Ent logic sysDefVal = do entId <- transSysId2VHDL (sid sysDefVal) inDecs <- mapM (uncurry $ transPort2IfaceSigDec In) (iIface sysDefVal) outDecs <- mapM (uncurry $ transPort2IfaceSigDec Out) (oIface sysDefVal) -- clock and reset implicit declarations let implicitDecs = if logic == Sequential then [IfaceSigDec resetId In std_logicTM, IfaceSigDec clockId In std_logicTM] else [] return $ EntityDec entId (implicitDecs ++ inDecs ++ outDecs) -- | Translate a 'ZipwithNSY' process to a block returning a declaration of -- the resulting signal. transZipWithN2Block :: Label -- ^ process identifier -> [VHDLId] -- ^ input signals -> Loc -- ^ location of the inner function -> TypedProcFunAST -- ^ AST of the inner function -> VHDLId -- ^ output signal -> VHDLM (BlockSm, SigDec) transZipWithN2Block vPid ins loc ast out = do -- Translate the process function (f,fName , inFPars, inFTypes, retFType) <- withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast -- Generate the formal parameters of the block let inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins] outPar = unsafeIdAppend vPid "_out" -- Generate the port interface of the block inDecs = zipWith (\par typ -> IfaceSigDec par In typ) inPars inFTypes outDec = IfaceSigDec outPar Out retFType iface = inDecs ++ [outDec] -- Generate the port map pMap = genPMap (inPars ++ [outPar]) (ins ++ [out]) -- Generate the function call and signal assignment outAssign = genFCallAssign out fName inFPars ins return (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign], SigDec out retFType Nothing) -- | Translate a 'ZipwithxSY' process to a block returning a declaration of -- the resulting signal. transZipWithx2Block :: Label -- ^ process identifier -> [VHDLId] -- ^ input signals -> Loc -- ^ location of the inner function -> TypedProcFunAST -- ^ AST of the inner function -> VHDLId -- ^ output signal -> VHDLM (BlockSm, SigDec) transZipWithx2Block vPid ins loc ast out = do -- Translate the process function (f, fName, [inFPar], [inFType], retFType) <- withProcFunC ((name.tpast) ast) loc $ transProcFun2VHDL ast -- Figure out the type of the inputs from the -- function's input vector type (horrible hack, but it works) let [[_,suffix]] = (fromVHDLId inFType) =~ "^fsvec_[0-9]*_(.*)$" inType = unsafeVHDLBasicId $ suffix -- Generate the formal parameters of the block inPars = map (\n -> unsafeIdAppend vPid ("_in" ++ show n)) [1..length ins] outPar = unsafeIdAppend vPid "_out" -- Generate the port interface of the block inDecs = map (\par -> IfaceSigDec par In inType) inPars outDec = IfaceSigDec outPar Out retFType iface = inDecs ++ [outDec] -- Generate the port map pMap = genPMap (inPars ++ [outPar]) (ins ++ [out]) -- Generate the function call and signal assignment aggregate = Aggregate $ map (\e -> ElemAssoc Nothing (PrimName(NSimple e))) inPars fCall = PrimFCall $ FCall (NSimple fName) [Just inFPar :=>: ADExpr aggregate] outAssign = genExprAssign outPar fCall return (BlockSm vPid iface pMap [BDISPB f] [CSSASm outAssign], SigDec out retFType Nothing) -- | Translate a 'UnzipNSY' process to a block returning a declaration of -- the resulting signal. transUnzipNSY2Block :: Label -- ^ process identifier -> VHDLId -- ^ input signal -> [VHDLId] -- ^ output signals -> [FSDTypeRep] -- ^ output signal types -> VHDLM (BlockSm, [SigDec]) transUnzipNSY2Block vPid inSig outSigs outTRTypes = do -- Generate the formal parameters of the block let inPar = unsafeIdAppend vPid "_in" outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n)) [1..length outSigs] -- Generate the port interface of the block nOuts = length outSigs inTRType = (fsdTupleTyCon nOuts) `fsdTyConApp` outTRTypes outTMTypes <- mapM transTR2TM outTRTypes inTMType <- transTR2TM inTRType let inDec = IfaceSigDec inPar In inTMType outDecs = zipWith (\par typ -> IfaceSigDec par Out typ) outPars outTMTypes iface = inDec : outDecs -- Generate the port map pMap = genPMap (inPar : outPars) (inSig : outSigs) -- Generate the signal assignments genOrigExp n = (PrimName $ NSelected (NSimple inPar :.: tupVHDLSuffix n)) genOutAssign outSig n = CSSASm $ genExprAssign outSig (genOrigExp n) outAssigns = zipWith genOutAssign outPars [(1::Int)..] return (BlockSm vPid iface pMap [] outAssigns, zipWith (\sig typ -> SigDec sig typ Nothing) outSigs outTMTypes) -- | Translate a 'UnzipxSY' process to a block returning a declaration of -- the resulting signal. transUnzipxSY2Block :: Label -- ^ process identifier -> VHDLId -- ^ input signal -> [VHDLId] -- ^ output signals -> FSDTypeRep -- ^ type of vector elements -> Int -- ^ vector Size -> VHDLM (BlockSm, [SigDec]) transUnzipxSY2Block vPid inSig outSigs elemTR vSize = do -- Generate the formal parameters of the block let inPar = unsafeIdAppend vPid "_in" outPars = map (\n -> unsafeIdAppend vPid ("_out" ++ show n)) [1..length outSigs] -- Generate the port interface of the block inTRType = fSVecTyCon `fsdTyConApp` [transInt2TLNat vSize, elemTR] inTMType <- transTR2TM inTRType elemTM <- transTR2TM elemTR let inDec = IfaceSigDec inPar In inTMType outDecs = map (\par -> IfaceSigDec par Out elemTM) outPars iface = inDec : outDecs -- Generate the port map pMap = genPMap (inPar : outPars) (inSig : outSigs) -- Generate the signal assignments genOrigExp n = PrimName $ NIndexed (NSimple inPar `IndexedName` [PrimLit $ show n]) genOutAssign outSig n = CSSASm $ genExprAssign outSig (genOrigExp n) outAssigns = zipWith genOutAssign outPars [(0::Int)..] return (BlockSm vPid iface pMap [] outAssigns, map (\sig -> SigDec sig elemTM Nothing) outSigs) -- | Translate a 'DelaySY' process to a block returning a declaration of -- the resulting signal. transDelay2Block :: Label -- ^ process identifier -> VHDLId -- ^ input signal -> ProcValAST -- ^ AST of the initial value -- of the delay process -> VHDLId -- ^ output signal -> VHDLM (BlockSm, SigDec) transDelay2Block vPid inS (ProcValAST exp tr enums) outS = do -- Add the enumerated types associated with the value to the global results addEnumTypes enums -- Get the type of the initial value initTR <- transTR2TM tr -- Translate the initial value initExp <- withProcValC exp $ withInitFunTransST $ (transExp2VHDL exp) -- Build the block let formalIn = unsafeIdAppend vPid "_in" formalOut = unsafeIdAppend vPid "_out" iface = [IfaceSigDec resetId In std_logicTM, IfaceSigDec clockId In std_logicTM, IfaceSigDec formalIn In initTR, IfaceSigDec formalOut Out initTR] assocs = [Just resetId :=>: ADName (NSimple resetId), Just clockId :=>: ADName (NSimple clockId), Just formalIn :=>: ADName (NSimple inS), Just formalOut :=>: ADName (NSimple outS)] sigAssign = CSSASm (NSimple formalOut :<==: (ConWforms [whenElseReset] inWform (Just whenRE))) whenElseReset = WhenElse (Wform [WformElem initExp Nothing]) (PrimName (NSimple resetId) :=: PrimLit "'0'") inWform = Wform [WformElem (PrimName $ NSimple formalIn) Nothing] whenRE = When (PrimFCall $ FCall (NSimple $ unsafeVHDLBasicId "rising_edge") [Nothing :=>: ADName (NSimple clockId) ]) return (BlockSm vPid iface (PMapAspect assocs) [] [sigAssign], SigDec outS initTR Nothing) -- | Translate a System instance into a VHDL component instantion -- returning the declartion of the output signals transSysIns2CompIns :: SysLogic -- ^ parent system logic -> Label -- ^ instance identifier -> [VHDLId] -- ^ input signals -> [(VHDLId, FSDTypeRep)] -- ^ output signals -> SysId -- ^ parent system identifier -> [PortId] -- ^ parent input identifiers -> [PortId] -- ^ parent output identifiers -> VHDLM (Maybe CompInsSm, [SigDec]) transSysIns2CompIns logic vPid ins typedOuts parentId parentInIds parentOutIds = do if length ins == 0 && length typedOuts == 0 then return (Nothing, []) else do -- Create the declarations for the signals decs <- mapM (\(name,typ) -> transVHDLName2SigDec name typ Nothing) typedOuts -- Create the portmap vParentId <- transSysId2VHDL parentId vParentInIds <- liftEProne $ mapM mkVHDLExtId parentInIds vParentOutIds <- liftEProne $ mapM mkVHDLExtId parentOutIds let implicitAssocIds = if logic == Sequential then [resetId, clockId] else [] assocs = genAssocElems (implicitAssocIds ++ vParentInIds ++ vParentOutIds) (implicitAssocIds ++ ins ++ map fst typedOuts) entityName = NSelected (NSimple workId :.: SSimple vParentId) instantiation = CompInsSm vPid (IUEntity entityName) (PMapAspect assocs) return (Just instantiation, decs) -- | Translate a VHDL Signal to a VHDL Signal declaration transVHDLName2SigDec :: SimpleName -- ^ Signal name -> FSDTypeRep -- ^ Type of the intermediate signal -> Maybe TH.Exp -- ^ Maybe an initializer expression for the signal -> VHDLM SigDec transVHDLName2SigDec vId tr mExp = do tm <- transTR2TM tr mVExp <- DT.mapM (\e -> withInitFunTransST (transExp2VHDL e)) mExp return $ SigDec vId tm mVExp ------------------------- -- Identifier translation ------------------------- -- | Translate a VHDL identifier and a type to an interface signal declaration transVHDLId2IfaceSigDec :: Mode -> VHDLId -> FSDTypeRep -> VHDLM IfaceSigDec transVHDLId2IfaceSigDec m vid trep = do tm <- transTR2TM trep return $ IfaceSigDec vid m tm -- | Translate a Port to a VHDL Interface signal declaration transPort2IfaceSigDec :: Mode -> PortId -> FSDTypeRep -> VHDLM IfaceSigDec transPort2IfaceSigDec m pid trep = do sid <- transPortId2VHDL pid transVHDLId2IfaceSigDec m sid trep -- | Translate a local TH name to a VHDL Identifier transTHName2VHDL :: TH.Name -> VHDLM VHDLId -- we use pprint becase it shows unique names for local names -- e.g. let x = 1 in let x =2 in x is printed as -- let x_0 = 1 in let x_1 = 2 in x_1 -- we want unique names because it saves us from dealing wiht -- name scopes and having a global name table. transTHName2VHDL = transPortId2VHDL . tyconUQname . pprint -- | Translate a system identifier to a VHDL identifier transSysId2VHDL :: SysId -> VHDLM VHDLId transSysId2VHDL = transPortId2VHDL -- | Translate a process identifier to a VHDL identifier transProcId2VHDL :: ProcId -> VHDLM VHDLId transProcId2VHDL = transPortId2VHDL -- | translate a port identifier to a VHDL Identifier transPortId2VHDL :: PortId -> VHDLM VHDLId transPortId2VHDL str = liftEProne $ mkVHDLExtId str ------------------- -- Type translation ------------------- -- | translate a 'TypeRep' to a VHDL 'TypeMark' -- We don't distinguish between a type and its version nested in 'Signal' -- since it makes no difference in VHDL transTR2TM :: FSDTypeRep -> VHDLM TypeMark transTR2TM rep -- Is it a Signal? | isSignal = transTR2TM nestedTR `debug` (dbgStr "S") -- Is it a primitive type? | isJust mPrimitiveTM = return $ fromJust mPrimitiveTM `debug` (dbgStr "P") -- Non-Primitive type, try to translate it | otherwise = customTR2TM rep `debug` (dbgStr "T") where (isSignal, nestedTR) = let (tc,~[tr]) = fsdSplitTyConApp rep in (tc == signalTyCon, tr) signalTyCon = fsdTyConOf (undefined :: Signal ()) mPrimitiveTM = lookup rep primTypeTable dbgStr k = ">>>>" ++ k ++ " " ++ (typeRepQName rep) ++ "/" ++ (show rep) -- | Translate a custom 'TypeRep' to a VHDL 'TypeMark' customTR2TM :: FSDTypeRep -> VHDLM TypeMark customTR2TM rep = do -- Check if it was previously translated mTranslated <- lookupCustomType rep case mTranslated of -- Not translated previously Nothing -> do -- translate it e <- doCustomTR2TM rep -- update the translation table and the accumulated type declarations addCustomType rep e -- return the translation case e of Left (TypeDec id _) -> return id Right (SubtypeDec id _) -> return id -- Translated previously Just tm -> return tm `debug` "'--> (cache hit)" -- | Really do the translation (customTR2TM deals with caching) doCustomTR2TM :: FSDTypeRep -> VHDLM (Either TypeDec SubtypeDec) -- | FSVec? -- FSVecs are translated to subtypes of unconstrained vectors. -- All FSVec operations are translated as operations for the -- unconstrained type. doCustomTR2TM rep | isFSVec = do -- Translate the type of the elements contained in the vector valTM <- transTR2TM valueType -- Build the unconstrained vector identifier let vectorId = unsafeVHDLContainerId [valTM] ("fsvec_"++ fromVHDLId valTM) -- Obtain the unconstrained vector together with its functions and add them -- to the global traversing-results (if this wasn't previously done): -- * Check if the unconstrained array was previously translated vecs <- gets (transUnconsFSVecs.global) -- * if it wasn't ... when (not $ elem valueType vecs) `debug` (" vectors: " ++ (show vecs)) $ do -- create the unconstrained vector type and add it to the global -- results. _Only_ if we are not working with "FSVec _ Bit" becuase -- "type fsvec_std_logic" is already included in forsyde.vhd. when (valueType /= (fsdTy $ typeOf (undefined :: Bit))) ((addTypeDec $ TypeDec vectorId (TDA (UnconsArrayDef [fsvec_indexTM] valTM))) `debug` "allegiedly not FSVec _ Bit") -- Add the default functions for the unconstrained -- vector type to the global results let funs = genUnconsVectorFuns valTM vectorId mapM_ addSubProgBody funs -- Mark the unconstrained array as translated addUnconsFSVec $ valueType -- Create the vector subtype identifier let subvectorId = unsafeVHDLBasicId ("fsvec_" ++ show size ++ "_" ++ fromVHDLId valTM) -- Create the vector subtype declaration return $ Right $ SubtypeDec subvectorId (SubtypeIn vectorId (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimLit (show $ size-1))])) where (cons, ~[sizeType,valueType]) = fsdSplitTyConApp rep isFSVec = cons == fSVecTyCon size = transTLNat2Int sizeType -- | Tuple? doCustomTR2TM rep | isTuple = do -- Create the elements of the record fieldTMs <- mapM transTR2TM args let elems = zipWith (\fieldId fieldTM -> ElementDec fieldId fieldTM ) [tupVHDLIdSuffix n | n <- [1..]] fieldTMs -- Create the Type Declaration identifier recordId = unsafeVHDLContainerId fieldTMs $ (tupStrSuffix $ length fieldTMs) ++ "_" ++ (concatMap fromVHDLId.intersperse (unsafeVHDLBasicId "_")) fieldTMs -- Add the default functions for the tuple type to the global results funs = genTupleFuns fieldTMs recordId mapM_ addSubProgBody funs -- Create the record return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems)) where (cons, args) = fsdSplitTyConApp rep conStr = fsdTyConName cons isTuple = (length conStr > 2) && (all (==',') (reverse.tail.reverse.tail $ conStr)) -- | AbstExt? doCustomTR2TM rep | isAbsExt = do -- Create the elements of the record valueTM <- transTR2TM valueTR let elems = [ElementDec isPresentId booleanTM, ElementDec valueId valueTM ] -- Create the Type Declaration identifier recordId = unsafeVHDLContainerId [valueTM] $ "abs_ext_" ++ fromVHDLId valueTM -- Add the default functions for the vector type to the global results funs = genAbstExtFuns valueTM recordId mapM_ addSubProgBody funs -- Return the resulting the record return $ Left $ (TypeDec recordId (TDR $ RecordTypeDef elems)) where (cons, ~[valueTR]) = fsdSplitTyConApp rep absExtTyCon = fsdTyConOf (undefined :: AbstExt ()) isAbsExt = cons == absExtTyCon -- | Finally, it is an Enumerated algebraic type -- or an unkown custom type (in that case we throw an error) -- -- NOTE: It would be cleaner to have a different clauses for each case but -- since we need to access the state to check if it's an enumerated -- algebraic type, we cannot do it. doCustomTR2TM rep = do -- Get the accumulated Enumerated Algebraic Types eTys <- gets (enumTypes.global) -- Check if current Type representation can be found in eTys let strRep = typeRepQName rep let equalsRep (EnumAlgTy name _) = name == strRep case (S.toList.(S.filter equalsRep)) eTys of -- Found! [enumDef] -> liftM Left $ enumAlg2TypeDec enumDef `debug` (">>>>? "++strRep) -- Not found, unkown custom type _ -> throwFError $ UnsupportedType rep -- | Transform an enumerated Algebraic type to a VHDL -- TypeMark adding its default function to the global results enumAlg2TypeDec :: EnumAlgTy -- ^ Enumerated type definition -> VHDLM TypeDec enumAlg2TypeDec (EnumAlgTy tn cons) = do -- Get the TypeMark tMark <- liftEProne $ mkVHDLExtId tn -- Get the enumeration literals enumLits@(firstLit:_) <- liftEProne $ mapM mkVHDLExtId cons -- Add the default functions for the enumeration type let funs = genEnumAlgFuns tMark firstLit mapM_ addSubProgBody funs -- Create the enumeration type return (TypeDec tMark (TDE $ EnumTypeDef enumLits)) -- | Translation table for primitive types primTypeTable :: [(FSDTypeRep, TypeMark)] primTypeTable = [-- Commented out due to representation overflow -- (typeOf (undefined :: Int64), int64TM) , (fsdTypeOf (undefined :: Int32), int32TM) , (fsdTypeOf (undefined :: Int16), int16TM) , (fsdTypeOf (undefined :: Int8) , int8TM) , (fsdTypeOf (undefined :: Bool) , booleanTM) , (fsdTypeOf (undefined :: Bit) , std_logicTM)] --------------------------------------- -- Translating functions and expresions --------------------------------------- ------------------------ -- Translating functions ------------------------ -- | Throw a function error funErr :: VHDLFunErr -> VHDLM a funErr err = throwFError $ UntranslatableVHDLFun err -- | Translate a typed function AST to VHDL transProcFun2VHDL :: TypedProcFunAST -- ^ input ast -> VHDLM (SubProgBody, VHDLId, [VHDLId], [TypeMark], TypeMark) -- ^ Function, Function name, name of inputs, type of inputs, return type transProcFun2VHDL (TypedProcFunAST fType fEnums fAST) = do -- Add the enumerated types associated with the function to the global results addEnumTypes fEnums -- Check if the procFunAST fullfils the restrictions of the VHDL Backend -- FIXME: translate the default arguments (fName, fInputPats, fBodyExp, whereDecs) <- checkProcFunAST fAST -- Get the function spec and initialize the translation namespace (fSpec, fVHDLName, fVHDLPars, argsTM, retTM) <- transProcFunSpec fName fType fInputPats -- Translate the where declarations and them to the -- auxiliary declarations of the function transDecs whereDecs -- Translate the function's body putCurrentFunctionSpec fSpec bodySms <- transFunBodyExp2VHDL fBodyExp decs <- gets (auxDecs.funTransST.local) let fBody = SubProgBody fSpec decs bodySms return (fBody, fVHDLName, fVHDLPars, argsTM, retTM) -- | Translate a typed function AST to VHDL (only returning the functions body transProcFun2VHDLBody :: TypedProcFunAST -> VHDLM SubProgBody transProcFun2VHDLBody tpf = do (body, _, _, _, _) <- transProcFun2VHDL tpf return body -- | Translate a list of declarations to a list of process function -- ASTs decs2ProcFuns :: [Dec] -> VHDLM [TypedProcFunAST] decs2ProcFuns [] = return [] decs2ProcFuns decs = do (dec, t, name, clauses, restDecs) <- case decs of -- A type signature followed by its function declaration SigD n1 t : f@(FunD n2 cls) : xs | n1 == n2 -> return (f, t, n1, cls, xs) -- A type signature followed by its value declaration -- which will be translated to a function SigD n1 t : v@(ValD (VarP n2) bdy ds) : xs | n1 == n2 -> do return (v, t, n1, [Clause [] bdy ds] , xs) -- Otherwise the provided declaration block is not supported _ -> funErr $ UnsupportedDecBlock decs t' <- maybe (funErr $ PolyDec dec) return (type2FSDTypeRep t) let tpf = TypedProcFunAST t' S.empty (ProcFunAST name clauses []) restTPFs <- decs2ProcFuns restDecs return $ tpf:restTPFs -- | Tranlate a list of declarations and add them to the auxiliary -- declarations in the function translation state transDecs :: [Dec] -> VHDLM () transDecs decs = do -- Before anything, clear the previous declaration blocks -- FIXME: this shouldn't be here clearAux -- first we tranlsate the declarations to process functions tpfs <- decs2ProcFuns decs -- Before translating the process functions we add their names to the -- name translation table. It is important to note that, since -- Template Haskell makes local names unique (e.g. [| let x = 1 in -- let x = 2 in x |] is tranlsated to let x_0 = 1 in let x_1 = 2 in x_2), -- we don't have to take care of name scopes i.e. we can have a global name -- scope. mapM_ addDecName tpfs -- Translate the declarations to VHDL and add them -- to the auxiliary declarations of the function translation bodyDecs <- mapM (liftM SPSB . transProcFun2VHDLBody) tpfs addDecsToFunTransST bodyDecs where addDecName :: TypedProcFunAST -> VHDLM () addDecName (TypedProcFunAST t _ (ProcFunAST n _ _)) = do let arity = (length.fst.fsdUnArrowT) t vhdlId <- transTHName2VHDL n addTransNamePair n arity (genExprFCallN vhdlId arity) clearAux = do lState <- gets local let s = funTransST lState modify (\st -> st{local=lState{funTransST=s{auxDecs=[]}}}) -- | Check if a process function AST fulfils the VHDL backend restrictions. -- It returs the function TH-name its input paterns, its body expression, -- and the list of theclarations in the where construct. checkProcFunAST :: ProcFunAST -> VHDLM (Name, [Pat], Exp, [Dec]) -- FIXME: translate the default arguments! checkProcFunAST (ProcFunAST thName [Clause pats (NormalB exp) decs] []) = return (thName, pats, exp, decs) checkProcFunAST (ProcFunAST _ _ (_:_)) = intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec" (UntranslatableVHDLFun $ GeneralErr (Other "default parameters are not yet supported")) checkProcFunAST (ProcFunAST _ [Clause _ bdy@(GuardedB _) _] _) = funErr (FunGuardedBody bdy) checkProcFunAST (ProcFunAST _ clauses@(_:_) _) = funErr (MultipleClauses clauses) -- cannot happen checkProcFunAST (ProcFunAST _ [] _) = -- FIXME, use a custom error intError "ForSyDe.Backend.VHDL.Translate.checkProcFunSpec" (UntranslatableVHDLFun $ GeneralErr (Other "inconsistentency")) -- | Get the spec of a VHDL function from the Haskell function name, its type -- and its input patterns. This function also takes care of initalizing the -- translation namespace. transProcFunSpec :: TH.Name -- ^ Function name -> FSDTypeRep -- ^ Function type -> [Pat] -- ^ input patterns -> VHDLM (SubProgSpec, VHDLId, [VHDLId], [TypeMark], TypeMark) -- ^ translated function spec, function name, inpt parameters, input types -- and return types transProcFunSpec fName fType fPats = do -- FIXME: translate the default arguments! -- Get the input and output types let (argsTR, retTR) = fsdUnArrowT fType -- Check that the number of patterns equal the function parameter number expectedN = length argsTR `debug` ("expected (args): "++ (show (length argsTR))) actualN = length fPats `debug` ("actual (patterns): "++ (show (length fPats))) when (expectedN /= actualN) (funErr $ InsParamNum fName actualN) -- Get a VHDL identifier for each input pattern and -- initialize the translation namespace fVHDLParIds <- mapM transInputPat2VHDLId fPats -- Translate the function name fVHDLName <- transTHName2VHDL fName -- Translate the types argsTM <- mapM transTR2TM argsTR retTM <- transTR2TM retTR -- Create the spec let iface = zipWith (\name typ -> IfaceVarDec name typ) fVHDLParIds argsTM fSpec = Function fVHDLName iface retTM -- Finally, return the results return (fSpec, fVHDLName, fVHDLParIds, argsTM, retTM) -- | Translate an input pattern to a VHDLID, -- making the necessary changes in the translation namespace transInputPat2VHDLId :: TH.Pat -> VHDLM VHDLId transInputPat2VHDLId pat = do -- Get the parameter identifier id <- case pat of -- if we get a variable or and @ patterm, we just translate it to VHDL VarP name -> transTHName2VHDL name AsP name _ -> transTHName2VHDL name -- otherwise, generate a fresh identifier _ -> genFreshVHDLId -- Prepare the namespace for the pattern preparePatNameSpace (NSimple id) pat -- Finally return the generated id return id -- | prepare the translation namespace for an input pattern preparePatNameSpace :: Prefix -- ^ name prefix obtained so far -> Pat -- ^ pattern -> VHDLM () -- NOTE: a good alternative to adding selected names to the -- translation table would be declaring a variable -- assignment. It would probably make the generated code more -- readable but at the same time, it requires knowing the -- pattern type, and TH's AST is unfortunately not -- type-annotated which would make things more difficult. -- variable pattern preparePatNameSpace prefix (VarP name) = addTransNamePair name 0 (\[] -> PrimName prefix) -- '@' pattern preparePatNameSpace prefix (AsP name pat) = do addTransNamePair name 0 (\[] -> PrimName prefix) preparePatNameSpace prefix pat -- wildcard pattern preparePatNameSpace _ WildP = return () -- tuple pattern preparePatNameSpace prefix (TupP pats) = do let prepTup n pat = preparePatNameSpace (NSelected (prefix :.: tupVHDLSuffix n)) pat zipWithM_ prepTup [1..] pats -- AbstExt patterns -- Since we only support one clause per function -- they are not really useful, but we accept them anyways -- FIXME: true, they are not useful, but again, since we only support one -- clause per function they denote a programming error. Should they -- really be supported? preparePatNameSpace prefix (ConP name ~[pat]) | isAbstExt name = when isPrst (preparePatNameSpace (NSelected (prefix :.: valueSuffix)) pat) where isAbstExt name = isPrst || name == 'Abst isPrst = name == 'Prst -- Unary Constructor patterns -- We try an enumerated type patterns -- otherwise we throw an unknown constructor pattern error preparePatNameSpace _ pat@(ConP name []) = do mId <- getEnumConsId name case mId of -- it is an enumerated data constructor, however, since we only admit -- one clause per function there is nothing to do about it Just _ -> return () -- it is an unknown data constructor Nothing -> funErr $ UnsupportedFunPat pat -- otherwise the pattern is not supported preparePatNameSpace _ pat = funErr $ UnsupportedFunPat pat -------------------------- -- Translating expressions -------------------------- -- | Throw an expression error expErr :: Exp -> VHDLExpErr -> VHDLM a expErr exp err = throwFError $ UntranslatableVHDLExp exp err -- | Create the unique statement of a VHDL from a TH expression. transFunBodyExp2VHDL :: TH.Exp -> VHDLM [SeqSm] transFunBodyExp2VHDL (CondE condE thenE elseE) = do condVHDLE <- transExp2VHDL condE thenVHDLSm <- transFunBodyExp2VHDL thenE elseVHDLSm <- transFunBodyExp2VHDL elseE return [IfSm condVHDLE thenVHDLSm [] (Just $ Else elseVHDLSm)] transFunBodyExp2VHDL caseE@(CaseE exp matches) = do caseVHDLE <- transExp2VHDL exp caseSmAlts <- mapM (transMatch2VHDLCaseSmAlt caseE) matches return [CaseSm caseVHDLE caseSmAlts] -- A higher order function needs to be treated specially transFunBodyExp2VHDL e@(AppE _ _) | isHigherOrderFunction e = translateHigherOrderFunctionBody e -- In other case it is an expression returned directly transFunBodyExp2VHDL e = do vHDLe <- transExp2VHDL e return [ReturnSm $ Just vHDLe] -- | Translate a case alternative from Haskell to VHDL transMatch2VHDLCaseSmAlt :: TH.Exp -> TH.Match -> VHDLM CaseSmAlt -- FIXME: the exp passed (which contains the full case expression for -- error reporting purposes) should be part of the context once VHDLM -- is reworked transMatch2VHDLCaseSmAlt contextExp (Match pat (NormalB matchExp) decs) = do transDecs decs sm <- transFunBodyExp2VHDL matchExp case pat of -- FIXME: support pattern matching with tuples, AbsExt, -- and enumerated types WildP -> return $ CaseSmAlt [Others] sm LitP lit -> do vHDLExp <- transExp2VHDL (LitE lit) return $ CaseSmAlt [ChoiceE vHDLExp] sm -- FIXME: check! this case introduces new names into scope VarP name -> do vHDLExp <- transExp2VHDL (VarE name) return $ CaseSmAlt [ChoiceE vHDLExp] sm _ -> expErr contextExp $ UnsupportedCasePat pat transMatch2VHDLCaseSmAlt contextExp (Match _ bdy@(GuardedB _) _) = expErr contextExp $ CaseGuardedBody bdy -- | Translate a Haskell expression to a VHDL expression transExp2VHDL :: TH.Exp -> VHDLM VHDL.Expr -- TypeLevel-package numerical constant aliases transExp2VHDL (VarE name) | isTypeLevelAlias = do let constant = nameBase name ([baseSym], val) = splitAt 1 constant basePrefix = case baseSym of 'b' -> "2#" 'o' -> "8#" 'h' -> "16#" 'd' -> "" _ -> error "unexpected base symbol" return (PrimLit $ basePrefix ++ val) where isTypeLevelAlias = (show name =~ aliasPat) aliasPat = "^Data\\.TypeLevel\\.Num\\.Aliases\\.(b[0-1]+|o[0-7]+|d[0-9]+|h[0-9A-F]+)$" -- A FSVec generated with Template Haskell transExp2VHDL (VarE unsafeFSVecCoerce `AppE` _ `AppE` (ConE con `AppE` ListE exps)) | show unsafeFSVecCoerce == "Data.Param.FSVec.unsafeFSVecCoerce" && show con == "Data.Param.FSVec.FSVec" = do vhdlExps <- mapM transExp2VHDL exps return $ Aggregate (map (\e -> ElemAssoc Nothing e) vhdlExps) -- Is it function/constructor application, a constant -- or an unkown name. transExp2VHDL e | isConsOrFun = do -- get the symbol table (name translation table) nameTable <- gets (nameTable.funTransST.local) case lookup name nameTable of -- found name Just (arity, transF) -> if arity /= numArgs then expErr e $ CurryUnsupported arity numArgs else do exps <- mapM transExp2VHDL args return $ transF exps -- Didn't find the name in the global table Nothing -> do -- Check if it is a user-defined enumerated data constructor mId <- getEnumConsId name case mId of Just id -> return $ PrimName (NSimple id) Nothing -> expErr e $ UnkownIdentifier name where (f,args,numArgs) = unApp e mName = getName f name = fromJust mName isConsOrFun = isJust mName getName (VarE n) = Just n getName (ConE n) = Just n getName _ = Nothing -- Literals transExp2VHDL (LitE (IntegerL integer)) = (return.transInteger2VHDL) integer transExp2VHDL (LitE (IntPrimL integer)) = (return.transInteger2VHDL) integer -- Unsupported literal transExp2VHDL lit@(LitE _) = expErr lit $ UnsupportedLiteral -- Infix expressions transExp2VHDL (InfixE (Just argl) f@(VarE _) (Just argr)) = transExp2VHDL $ f `AppE` argl `AppE` argr -- Sections (unsupported) transExp2VHDL infixExp@(InfixE _ (VarE _) _) = expErr infixExp Section -- Tuples: e.g. (1,2) transExp2VHDL (TupE exps) = do vExps <- mapM transExp2VHDL exps return $ Aggregate $ map (\expr -> ElemAssoc Nothing expr) vExps -- Let expressions transExp2VHDL (LetE decs e) = do transDecs decs transExp2VHDL e -- Unsupported expressions transExp2VHDL lamE@(LamE _ _) = expErr lamE LambdaAbstraction transExp2VHDL condE@(CondE _ _ _) = expErr condE Conditional transExp2VHDL caseE@(CaseE _ _) = expErr caseE Case transExp2VHDL doE@(DoE _) = expErr doE Do transExp2VHDL compE@(CompE _) = expErr compE ListComprehension transExp2VHDL arithSeqE@(ArithSeqE _) = expErr arithSeqE ArithSeq transExp2VHDL listE@(ListE _) = expErr listE List transExp2VHDL sigE@(SigE _ _) = expErr sigE Signature transExp2VHDL reConE@(RecConE _ _) = expErr reConE Record transExp2VHDL recUpE@(RecUpdE _ _) = expErr recUpE Record -- The rest of expressions are not valid in practice and thus, not supported -- (e.g. InfixE Nothing (RecConE _ _) _ transExp2VHDL exp = expErr exp Unsupported -- | Translate an integer to VHDL transInteger2VHDL :: Integer -> Expr transInteger2VHDL = PrimLit . show -------------------- -- Helper Functions -------------------- -- Translate the TypeRep of a type-level natural (e.g: D1 :* D2) to a number -- Make sure you don't supply an incorrect TypeRep or the function will break transTLNat2Int :: FSDTypeRep -> Int transTLNat2Int tr -- Digit -- FIXME: Could be made cleaner. It was like this before: -- isDigit = (digitToInt.last.tyConName) cons -- which was not able to take care of e.g. Data.TypeLevel.Num.Aliases.D10 | isDigit = (read.reverse.takeWhile (/='D').reverse.fsdTyConName) cons -- Connective | otherwise = 10 * (transTLNat2Int prefix) + (transTLNat2Int lastDigit) where (cons, args@(~[prefix, lastDigit])) = fsdSplitTyConApp tr isDigit = null args -- Tranlate an Int to the TypeRep of a type-level natural (e.g: D1 :* D2) transInt2TLNat :: Int -> FSDTypeRep transInt2TLNat n | n < 0 = intError fName (Other "negative index") | n < 10 = digit n | otherwise = fsdTyConApp conTyCon [transInt2TLNat suffix, digit last] where fName = "ForSyDe.Backend.VHDL.Translate.transInt2TLNat" (suffix, last) = n `divMod` 10 digit 0 = fsdTypeOf (undefined :: D0) digit 1 = fsdTypeOf (undefined :: D1) digit 2 = fsdTypeOf (undefined :: D2) digit 3 = fsdTypeOf (undefined :: D3) digit 4 = fsdTypeOf (undefined :: D4) digit 5 = fsdTypeOf (undefined :: D5) digit 6 = fsdTypeOf (undefined :: D6) digit 7 = fsdTypeOf (undefined :: D7) digit 8 = fsdTypeOf (undefined :: D8) digit 9 = fsdTypeOf (undefined :: D9) -- Just to hush the compiler warnings digit _ = undefined conTyCon = fsdTyConOf (undefined :: () :* ()) -- Type constructor of FSVec fSVecTyCon :: FSDTypeCon fSVecTyCon = fsdTyConOf (undefined :: V.FSVec () ()) -- unApply an expression and obtain the number of arguments found unApp :: Exp -> (Exp, [Exp], Int) unApp e = (first, rest, n) where (first:rest, n) = unAppAc ([],0) e unAppAc (xs,n) (f `AppE` arg) = unAppAc (arg:xs, n+1) f unAppAc (xs,n) f = (f:xs,n) typeRepQName :: FSDTypeRep -> String typeRepQName rep = mod ++ dot ++ name where tr = fsdTyRep rep tc = typeRepTyCon tr mod = tyConModule tc name = tyConName tc dot = if mod=="" then "" else "."