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     argports   = map (Monad.liftM fst) (ent_args entity)
  57     resport     = (Monad.liftM fst) (ent_res entity)
  58     -- Assign the ports
  59     inport      = mkAssocElemIndexed (argports!!0) (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 genZipWithCall ::
  70   Entity
  71   -> [CoreSyn.CoreBndr]
  72   -> VHDLSession AST.GenerateSm
  73 genZipWithCall entity [arg1, arg2, res] = return $ genSm
  74   where
  75     -- Setup the generate scheme
  76     len         = (tfvec_len . Var.varType) res
  77     label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
  78     nPar        = AST.unsafeVHDLBasicId "n"
  79     range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
  80     genScheme   = AST.ForGn nPar range
  81     -- Get the entity name and port names
  82     entity_id   = ent_id entity
  83     argports    = map (Monad.liftM fst) (ent_args entity)
  84     resport     = (Monad.liftM fst) (ent_res entity)
  85     -- Assign the ports
  86     inport1     = mkAssocElemIndexed (argports!!0) (varToString arg1) nPar
  87     inport2     = mkAssocElemIndexed (argports!!1) (varToString arg2) nPar
  88     outport     = mkAssocElemIndexed resport (varToString res) nPar
  89     clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
  90     portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
  91     -- Generate the portmap
  92     mapLabel    = "zipWith" ++ (AST.fromVHDLId entity_id)
  93     compins     = mkComponentInst mapLabel entity_id portassigns
  94     -- Return the generate functions
  95     genSm       = AST.GenerateSm label genScheme [] [compins]
  96
  97 -- Returns the VHDLId of the vector function with the given name for the given
  98 -- element type. Generates -- this function if needed.
  99 vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
 100 vectorFunId el_ty fname = do
 101   elemTM <- vhdl_ty el_ty
 102   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
 103   -- the VHDLState or something.
 104   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
 105   typefuns <- getA vsTypeFuns
 106   case Map.lookup (OrdType el_ty, fname) typefuns of
 107     -- Function already generated, just return it
 108     Just (id, _) -> return id
 109     -- Function not generated yet, generate it
 110     Nothing -> do
 111       let functions = genUnconsVectorFuns elemTM vectorTM
 112       case lookup fname functions of
 113         Just body -> do
 114           modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
 115           return function_id
 116         Nothing -> error $ "I don't know how to generate vector function " ++ fname
 117   where
 118     function_id = mkVHDLExtId fname
 119
 120 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
 121                     -> AST.TypeMark -- ^ type of the vector
 122                     -> [(String, AST.SubProgBody)]
 123 genUnconsVectorFuns elemTM vectorTM  =
 124   [ (exId, AST.SubProgBody exSpec      []                  [exExpr])
 125   , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
 126   , (headId, AST.SubProgBody headSpec    []                  [headExpr])
 127   , (lastId, AST.SubProgBody lastSpec    []                  [lastExpr])
 128   , (initId, AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet])
 129   , (tailId, AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet])
 130   , (takeId, AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet])
 131   , (dropId, AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet])
 132   , (plusgtId, AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
 133   , (emptyId, AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr])
 134   , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
 135   , (copyId, AST.SubProgBody copySpec    [AST.SPVD copyVar]      [copyExpr])
 136   ]
 137   where
 138     ixPar   = AST.unsafeVHDLBasicId "ix"
 139     vecPar  = AST.unsafeVHDLBasicId "vec"
 140     nPar    = AST.unsafeVHDLBasicId "n"
 141     iId     = AST.unsafeVHDLBasicId "i"
 142     iPar    = iId
 143     aPar    = AST.unsafeVHDLBasicId "a"
 144     resId   = AST.unsafeVHDLBasicId "res"
 145     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
 146                                AST.IfaceVarDec ixPar  naturalTM] elemTM
 147     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
 148               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
 149                 AST.NSimple ixPar]))
 150     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
 151                                           , AST.IfaceVarDec iPar   naturalTM
 152                                           , AST.IfaceVarDec aPar   elemTM
 153                                           ] vectorTM
 154        -- variable res : fsvec_x (0 to vec'length-1);
 155     replaceVar =
 156          AST.VarDec resId
 157                 (AST.SubtypeIn vectorTM
 158                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 159                    [AST.ToRange (AST.PrimLit "0")
 160                             (AST.PrimName (AST.NAttribute $
 161                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 162                                 (AST.PrimLit "1"))   ]))
 163                 Nothing
 164        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
 165     replaceExpr = AST.NSimple resId AST.:=
 166            (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
 167             AST.PrimName (AST.NSimple aPar) AST.:&:
 168              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
 169                       ((AST.PrimName (AST.NAttribute $
 170                                 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))
 171                                                               AST.:-: AST.PrimLit "1"))
 172     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 173     vecSlice init last =  AST.PrimName (AST.NSlice
 174                                         (AST.SliceName
 175                                               (AST.NSimple vecPar)
 176                                               (AST.ToRange init last)))
 177     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 178        -- return vec(0);
 179     headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 180                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
 181     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 182        -- return vec(vec'length-1);
 183     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 184                     (AST.NSimple vecPar)
 185                     [AST.PrimName (AST.NAttribute $
 186                                 AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 187                                                              AST.:-: AST.PrimLit "1"])))
 188     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 189        -- variable res : fsvec_x (0 to vec'length-2);
 190     initVar =
 191          AST.VarDec resId
 192                 (AST.SubtypeIn vectorTM
 193                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 194                    [AST.ToRange (AST.PrimLit "0")
 195                             (AST.PrimName (AST.NAttribute $
 196                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 197                                 (AST.PrimLit "2"))   ]))
 198                 Nothing
 199        -- resAST.:= vec(0 to vec'length-2)
 200     initExpr = AST.NSimple resId AST.:= (vecSlice
 201                                (AST.PrimLit "0")
 202                                (AST.PrimName (AST.NAttribute $
 203                                   AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 204                                                              AST.:-: AST.PrimLit "2"))
 205     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 206     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 207        -- variable res : fsvec_x (0 to vec'length-2);
 208     tailVar =
 209          AST.VarDec resId
 210                 (AST.SubtypeIn vectorTM
 211                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 212                    [AST.ToRange (AST.PrimLit "0")
 213                             (AST.PrimName (AST.NAttribute $
 214                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 215                                 (AST.PrimLit "2"))   ]))
 216                 Nothing
 217        -- res AST.:= vec(1 to vec'length-1)
 218     tailExpr = AST.NSimple resId AST.:= (vecSlice
 219                                (AST.PrimLit "1")
 220                                (AST.PrimName (AST.NAttribute $
 221                                   AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 222                                                              AST.:-: AST.PrimLit "1"))
 223     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 224     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
 225                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
 226        -- variable res : fsvec_x (0 to n-1);
 227     takeVar =
 228          AST.VarDec resId
 229                 (AST.SubtypeIn vectorTM
 230                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 231                    [AST.ToRange (AST.PrimLit "0")
 232                                ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 233                                 (AST.PrimLit "1"))   ]))
 234                 Nothing
 235        -- res AST.:= vec(0 to n-1)
 236     takeExpr = AST.NSimple resId AST.:=
 237                     (vecSlice (AST.PrimLit "1")
 238                               (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
 239     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 240     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
 241                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
 242        -- variable res : fsvec_x (0 to vec'length-n-1);
 243     dropVar =
 244          AST.VarDec resId
 245                 (AST.SubtypeIn vectorTM
 246                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 247                    [AST.ToRange (AST.PrimLit "0")
 248                             (AST.PrimName (AST.NAttribute $
 249                               AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
 250                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
 251                Nothing
 252        -- res AST.:= vec(n to vec'length-1)
 253     dropExpr = AST.NSimple resId AST.:= (vecSlice
 254                                (AST.PrimName $ AST.NSimple nPar)
 255                                (AST.PrimName (AST.NAttribute $
 256                                   AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)
 257                                                              AST.:-: AST.PrimLit "1"))
 258     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 259     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
 260                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
 261     -- variable res : fsvec_x (0 to vec'length);
 262     plusgtVar =
 263       AST.VarDec resId
 264              (AST.SubtypeIn vectorTM
 265                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 266                 [AST.ToRange (AST.PrimLit "0")
 267                         (AST.PrimName (AST.NAttribute $
 268                           AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))]))
 269              Nothing
 270     plusgtExpr = AST.NSimple resId AST.:=
 271                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
 272                     (AST.PrimName $ AST.NSimple vecPar))
 273     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 274     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
 275     emptyVar =
 276           AST.ConstDec resId
 277               (AST.SubtypeIn vectorTM Nothing)
 278               (Just $ AST.PrimLit "\"\"")
 279     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
 280     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
 281                                          vectorTM
 282     -- variable res : fsvec_x (0 to 0) := (others => a);
 283     singletonVar =
 284       AST.VarDec resId
 285              (AST.SubtypeIn vectorTM
 286                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 287                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
 288              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 289                                           (AST.PrimName $ AST.NSimple aPar)])
 290     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 291     copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar   naturalTM,
 292                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
 293     -- variable res : fsvec_x (0 to n-1) := (others => a);
 294     copyVar =
 295       AST.VarDec resId
 296              (AST.SubtypeIn vectorTM
 297                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 298                 [AST.ToRange (AST.PrimLit "0")
 299                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 300                              (AST.PrimLit "1"))   ]))
 301              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 302                                           (AST.PrimName $ AST.NSimple aPar)])
 303     -- return res
 304     copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)