Generate.hs

   1 module Generate where
   2
   3 -- Standard modules
   4 import qualified Control.Monad as Monad
   5 import qualified Data.Map as Map
   6 import qualified Maybe
   7 import Data.Accessor
   8
   9 -- ForSyDe
  10 import qualified ForSyDe.Backend.VHDL.AST as AST
  11
  12 -- GHC API
  13 import CoreSyn
  14 import Type
  15 import qualified Var
  16
  17 -- Local imports
  18 import Constants
  19 import VHDLTypes
  20 import VHDLTools
  21 import CoreTools
  22
  23 -- | Generate a binary operator application. The first argument should be a
  24 -- constructor from the AST.Expr type, e.g. AST.And.
  25 genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
  26 genExprOp2 op res [arg1, arg2] = return $ op arg1 arg2
  27
  28 -- | Generate a unary operator application
  29 genExprOp1 :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
  30 genExprOp1 op res [arg] = return $ op arg
  31
  32 -- | Generate a function call from the destination binder, function name and a
  33 -- list of expressions (its arguments)
  34 genExprFCall :: String -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
  35 genExprFCall fname res args = do
  36   let el_ty = (tfvec_elem . Var.varType) res
  37   id <- vectorFunId el_ty fname
  38   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
  39              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
  40
  41 -- | Generate a generate statement for the builtin function "map"
  42 genMapCall ::
  43   Entity -- | The entity to map
  44   -> [CoreSyn.CoreBndr] -- | The vectors
  45   -> VHDLSession AST.GenerateSm -- | The resulting generate statement
  46 genMapCall entity [arg, res] = return $ genSm
  47   where
  48     -- Setup the generate scheme
  49     len         = (tfvec_len . Var.varType) res
  50     label       = mkVHDLExtId ("mapVector" ++ (varToString res))
  51     nPar        = AST.unsafeVHDLBasicId "n"
  52     range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
  53     genScheme   = AST.ForGn nPar range
  54     -- Get the entity name and port names
  55     entity_id   = ent_id entity
  56     argport     = map (Monad.liftM fst) (ent_args entity)
  57     resport     = (Monad.liftM fst) (ent_res entity)
  58     -- Assign the ports
  59     inport      = mkAssocElemIndexed (head argport) (varToString arg) nPar
  60     outport     = mkAssocElemIndexed resport (varToString res) nPar
  61     clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
  62     portassigns = Maybe.catMaybes [inport,outport,clk_port]
  63     -- Generate the portmap
  64     mapLabel    = "map" ++ (AST.fromVHDLId entity_id)
  65     compins     = mkComponentInst mapLabel entity_id portassigns
  66     -- Return the generate functions
  67     genSm       = AST.GenerateSm label genScheme [] [compins]
  68
  69 -- Returns the VHDLId of the vector function with the given name for the given
  70 -- element type. Generates -- this function if needed.
  71 vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
  72 vectorFunId el_ty fname = do
  73   elemTM <- vhdl_ty el_ty
  74   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
  75   -- the VHDLState or something.
  76   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
  77   typefuns <- getA vsTypeFuns
  78   case Map.lookup (OrdType el_ty, fname) typefuns of
  79     -- Function already generated, just return it
  80     Just (id, _) -> return id
  81     -- Function not generated yet, generate it
  82     Nothing -> do
  83       let functions = genUnconsVectorFuns elemTM vectorTM
  84       case lookup fname functions of
  85         Just body -> do
  86           modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
  87           return function_id
  88         Nothing -> error $ "I don't know how to generate vector function " ++ fname
  89   where
  90     function_id = mkVHDLExtId fname
  91
  92 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
  93                     -> AST.TypeMark -- ^ type of the vector
  94                     -> [(String, AST.SubProgBody)]
  95 genUnconsVectorFuns elemTM vectorTM  =
  96   [ (exId, AST.SubProgBody exSpec      []                  [exExpr])
  97   , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
  98   , (headId, AST.SubProgBody headSpec    []                  [headExpr])
  99   , (lastId, AST.SubProgBody lastSpec    []                  [lastExpr])
 100   , (initId, AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet])
 101   , (tailId, AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet])
 102   , (takeId, AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet])
 103   , (dropId, AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet])
 104   , (plusgtId, AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
 105   , (emptyId, AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr])
 106   , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
 107   , (copyId, AST.SubProgBody copySpec    [AST.SPVD copyVar]      [copyExpr])
 108   ]
 109   where
 110     ixPar   = AST.unsafeVHDLBasicId "ix"
 111     vecPar  = AST.unsafeVHDLBasicId "vec"
 112     nPar    = AST.unsafeVHDLBasicId "n"
 113     iId     = AST.unsafeVHDLBasicId "i"
 114     iPar    = iId
 115     aPar    = AST.unsafeVHDLBasicId "a"
 116     resId   = AST.unsafeVHDLBasicId "res"
 117     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
 118                                AST.IfaceVarDec ixPar  naturalTM] elemTM
 119     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
 120               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
 121                 AST.NSimple ixPar]))
 122     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
 123                                           , AST.IfaceVarDec iPar   naturalTM
 124                                           , AST.IfaceVarDec aPar   elemTM
 125                                           ] vectorTM
 126        -- variable res : fsvec_x (0 to vec'length-1);
 127     replaceVar =
 128          AST.VarDec resId
 129                 (AST.SubtypeIn vectorTM
 130                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 131                    [AST.ToRange (AST.PrimLit "0")
 132                             (AST.PrimName (AST.NAttribute $
 133                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 134                                 (AST.PrimLit "1"))   ]))
 135                 Nothing
 136        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
 137     replaceExpr = AST.NSimple resId AST.:=
 138            (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
 139             AST.PrimName (AST.NSimple aPar) AST.:&:
 140              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
 141                       ((AST.PrimName (AST.NAttribute $
 142                                 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))
 143                                                               AST.:-: AST.PrimLit "1"))
 144     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 145     vecSlice init last =  AST.PrimName (AST.NSlice
 146                                         (AST.SliceName
 147                                               (AST.NSimple vecPar)
 148                                               (AST.ToRange init last)))
 149     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 150        -- return vec(0);
 151     headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 152                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
 153     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 154        -- return vec(vec'length-1);
 155     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 156                     (AST.NSimple vecPar)
 157                     [AST.PrimName (AST.NAttribute $
 158                                 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 159                                                              AST.:-: AST.PrimLit "1"])))
 160     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 161        -- variable res : fsvec_x (0 to vec'length-2);
 162     initVar =
 163          AST.VarDec resId
 164                 (AST.SubtypeIn vectorTM
 165                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 166                    [AST.ToRange (AST.PrimLit "0")
 167                             (AST.PrimName (AST.NAttribute $
 168                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 169                                 (AST.PrimLit "2"))   ]))
 170                 Nothing
 171        -- resAST.:= vec(0 to vec'length-2)
 172     initExpr = AST.NSimple resId AST.:= (vecSlice
 173                                (AST.PrimLit "0")
 174                                (AST.PrimName (AST.NAttribute $
 175                                   AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 176                                                              AST.:-: AST.PrimLit "2"))
 177     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 178     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 179        -- variable res : fsvec_x (0 to vec'length-2);
 180     tailVar =
 181          AST.VarDec resId
 182                 (AST.SubtypeIn vectorTM
 183                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 184                    [AST.ToRange (AST.PrimLit "0")
 185                             (AST.PrimName (AST.NAttribute $
 186                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 187                                 (AST.PrimLit "2"))   ]))
 188                 Nothing
 189        -- res AST.:= vec(1 to vec'length-1)
 190     tailExpr = AST.NSimple resId AST.:= (vecSlice
 191                                (AST.PrimLit "1")
 192                                (AST.PrimName (AST.NAttribute $
 193                                   AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 194                                                              AST.:-: AST.PrimLit "1"))
 195     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 196     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
 197                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
 198        -- variable res : fsvec_x (0 to n-1);
 199     takeVar =
 200          AST.VarDec resId
 201                 (AST.SubtypeIn vectorTM
 202                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 203                    [AST.ToRange (AST.PrimLit "0")
 204                                ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 205                                 (AST.PrimLit "1"))   ]))
 206                 Nothing
 207        -- res AST.:= vec(0 to n-1)
 208     takeExpr = AST.NSimple resId AST.:=
 209                     (vecSlice (AST.PrimLit "1")
 210                               (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
 211     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 212     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
 213                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
 214        -- variable res : fsvec_x (0 to vec'length-n-1);
 215     dropVar =
 216          AST.VarDec resId
 217                 (AST.SubtypeIn vectorTM
 218                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 219                    [AST.ToRange (AST.PrimLit "0")
 220                             (AST.PrimName (AST.NAttribute $
 221                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 222                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
 223                Nothing
 224        -- res AST.:= vec(n to vec'length-1)
 225     dropExpr = AST.NSimple resId AST.:= (vecSlice
 226                                (AST.PrimName $ AST.NSimple nPar)
 227                                (AST.PrimName (AST.NAttribute $
 228                                   AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 229                                                              AST.:-: AST.PrimLit "1"))
 230     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 231     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
 232                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
 233     -- variable res : fsvec_x (0 to vec'length);
 234     plusgtVar =
 235       AST.VarDec resId
 236              (AST.SubtypeIn vectorTM
 237                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 238                 [AST.ToRange (AST.PrimLit "0")
 239                         (AST.PrimName (AST.NAttribute $
 240                           AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))]))
 241              Nothing
 242     plusgtExpr = AST.NSimple resId AST.:=
 243                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
 244                     (AST.PrimName $ AST.NSimple vecPar))
 245     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 246     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
 247     emptyVar =
 248           AST.VarDec resId
 249               (AST.SubtypeIn vectorTM
 250                 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 251                  [AST.ToRange (AST.PrimLit "0")
 252                           (AST.PrimLit "-1")]))
 253               Nothing
 254     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
 255     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
 256                                          vectorTM
 257     -- variable res : fsvec_x (0 to 0) := (others => a);
 258     singletonVar =
 259       AST.VarDec resId
 260              (AST.SubtypeIn vectorTM
 261                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 262                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
 263              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 264                                           (AST.PrimName $ AST.NSimple aPar)])
 265     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 266     copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar   naturalTM,
 267                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
 268     -- variable res : fsvec_x (0 to n-1) := (others => a);
 269     copyVar =
 270       AST.VarDec resId
 271              (AST.SubtypeIn vectorTM
 272                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 273                 [AST.ToRange (AST.PrimLit "0")
 274                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 275                              (AST.PrimLit "1"))   ]))
 276              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 277                                           (AST.PrimName $ AST.NSimple aPar)])
 278     -- return res
 279     copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)