Generate.hs

   1 module Generate where
   2
   3 -- Standard modules
   4 import qualified Control.Monad as Monad
   5 import qualified Maybe
   6
   7 -- ForSyDe
   8 import qualified ForSyDe.Backend.VHDL.AST as AST
   9
  10 -- GHC API
  11 import CoreSyn
  12 import qualified Var
  13
  14 -- Local imports
  15 import Constants
  16 import VHDLTypes
  17 import VHDLTools
  18 import CoreTools
  19
  20 -- | Generate a binary operator application. The first argument should be a
  21 -- constructor from the AST.Expr type, e.g. AST.And.
  22 genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> [AST.Expr] -> VHDLSession AST.Expr
  23 genExprOp2 op [arg1, arg2] = return $ op arg1 arg2
  24
  25 -- | Generate a unary operator application
  26 genExprOp1 :: (AST.Expr -> AST.Expr) -> [AST.Expr] -> VHDLSession AST.Expr
  27 genExprOp1 op [arg] = return $ op arg
  28
  29 -- | Generate a function call from the Function Name and a list of expressions
  30 --   (its arguments)
  31 genExprFCall :: AST.VHDLId -> [AST.Expr] -> VHDLSession AST.Expr
  32 genExprFCall fName args =
  33    return $ AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
  34              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
  35
  36 -- | Generate a generate statement for the builtin function "map"
  37 genMapCall ::
  38   Entity -- | The entity to map
  39   -> [CoreSyn.CoreBndr] -- | The vectors
  40   -> VHDLSession AST.GenerateSm -- | The resulting generate statement
  41 genMapCall entity [arg, res] = return $ genSm
  42   where
  43     -- Setup the generate scheme
  44     len         = (tfvec_len . Var.varType) res
  45     label       = mkVHDLExtId ("mapVector" ++ (varToString res))
  46     nPar        = AST.unsafeVHDLBasicId "n"
  47     range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
  48     genScheme   = AST.ForGn nPar range
  49     -- Get the entity name and port names
  50     entity_id   = ent_id entity
  51     argports   = map (Monad.liftM fst) (ent_args entity)
  52     resport     = (Monad.liftM fst) (ent_res entity)
  53     -- Assign the ports
  54     inport      = mkAssocElemIndexed (argports!!0) (varToString arg) nPar
  55     outport     = mkAssocElemIndexed resport (varToString res) nPar
  56     clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
  57     portassigns = Maybe.catMaybes [inport,outport,clk_port]
  58     -- Generate the portmap
  59     mapLabel    = "map" ++ (AST.fromVHDLId entity_id)
  60     compins     = mkComponentInst mapLabel entity_id portassigns
  61     -- Return the generate functions
  62     genSm       = AST.GenerateSm label genScheme [] [compins]
  63
  64 genZipWithCall ::
  65   Entity
  66   -> [CoreSyn.CoreBndr]
  67   -> AST.GenerateSm
  68 genZipWithCall entity [arg1, arg2, res] = genSm
  69   where
  70     -- Setup the generate scheme
  71     len         = (tfvec_len . Var.varType) res
  72     label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
  73     nPar        = AST.unsafeVHDLBasicId "n"
  74     range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
  75     genScheme   = AST.ForGn nPar range
  76     -- Get the entity name and port names
  77     entity_id   = ent_id entity
  78     argports    = map (Monad.liftM fst) (ent_args entity)
  79     resport     = (Monad.liftM fst) (ent_res entity)
  80     -- Assign the ports
  81     inport1     = mkAssocElemIndexed (argports!!0) (varToString arg1) nPar
  82     inport2     = mkAssocElemIndexed (argports!!1) (varToString arg2) nPar
  83     outport     = mkAssocElemIndexed resport (varToString res) nPar
  84     clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
  85     portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
  86     -- Generate the portmap
  87     mapLabel    = "zipWith" ++ (AST.fromVHDLId entity_id)
  88     compins     = mkComponentInst mapLabel entity_id portassigns
  89     -- Return the generate functions
  90     genSm       = AST.GenerateSm label genScheme [] [compins]
  91
  92 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
  93                     -> AST.TypeMark -- ^ type of the vector
  94                     -> [AST.SubProgBody]
  95 genUnconsVectorFuns elemTM vectorTM  =
  96   [ AST.SubProgBody exSpec      []                  [exExpr]
  97   , AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet]
  98   , AST.SubProgBody headSpec    []                  [headExpr]
  99   , AST.SubProgBody lastSpec    []                  [lastExpr]
 100   , AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet]
 101   , AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet]
 102   , AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet]
 103   , AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet]
 104   , AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet]
 105   , AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr]
 106   , AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet]
 107   , 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 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 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) 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) 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 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 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) lengthId Nothing)
 159                                                              AST.:-: AST.PrimLit "1"])))
 160     initSpec = AST.Function 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) 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) lengthId Nothing)
 176                                                              AST.:-: AST.PrimLit "2"))
 177     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 178     tailSpec = AST.Function 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) 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) lengthId Nothing)
 194                                                              AST.:-: AST.PrimLit "1"))
 195     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 196     takeSpec = AST.Function 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 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) 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) lengthId Nothing)
 229                                                              AST.:-: AST.PrimLit "1"))
 230     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 231     plusgtSpec = AST.Function 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) 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 emptyId [] vectorTM
 247     emptyVar =
 248           AST.ConstDec resId
 249               (AST.SubtypeIn vectorTM Nothing)
 250               (Just $ AST.PrimLit "\"\"")
 251     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
 252     singletonSpec = AST.Function singletonId [AST.IfaceVarDec aPar elemTM ]
 253                                          vectorTM
 254     -- variable res : fsvec_x (0 to 0) := (others => a);
 255     singletonVar =
 256       AST.VarDec resId
 257              (AST.SubtypeIn vectorTM
 258                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 259                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
 260              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 261                                           (AST.PrimName $ AST.NSimple aPar)])
 262     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 263     copySpec = AST.Function copyId [AST.IfaceVarDec nPar   naturalTM,
 264                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
 265     -- variable res : fsvec_x (0 to n-1) := (others => a);
 266     copyVar =
 267       AST.VarDec resId
 268              (AST.SubtypeIn vectorTM
 269                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 270                 [AST.ToRange (AST.PrimLit "0")
 271                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 272                              (AST.PrimLit "1"))   ]))
 273              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 274                                           (AST.PrimName $ AST.NSimple aPar)])
 275     -- return res
 276     copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)