X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;ds=sidebyside;f=Generate.hs;h=14589194e04dd95ba4a00788a3ca08ef1f392db9;hb=ce7380ad772e2a81c0329c6ee495e18fa0a62280;hp=4a96175a9164151f89277fba9158b7c3ec55b414;hpb=f6fe50cbfd8820da8ba4af6d1e09b641adffb686;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Generate.hs b/Generate.hs index 4a96175..1458919 100644 --- a/Generate.hs +++ b/Generate.hs @@ -80,13 +80,15 @@ genFCall' (Left res) f args = do id <- vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args -genFCall' (Right name) _ _ = error $ "Cannot generate builtin function call assigned to a VHDLName: " ++ show name +genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder -genMap = genVarArgs genMap' -genMap' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] -genMap' (Left res) f [mapped_f, arg] = +genMap (Left res) f [Left mapped_f, Left (Var arg)] = + -- 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 + -- VHDLNames can be indexed). let -- Setup the generate scheme len = (tfvec_len . Var.varType) res @@ -102,11 +104,13 @@ genMap' (Left res) f [mapped_f, arg] = resname = mkIndexedName (varToVHDLName res) n_expr argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr in do - app_concsms <- genApplication (Right resname) mapped_f [Right argexpr] + let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f + let valargs = get_val_args (Var.varType real_f) already_mapped_args + app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr]) -- Return the generate statement return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms] -genMap' (Right name) _ _ = error $ "Cannot generate map function call assigned to a VHDLName: " ++ show name +genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name genZipWith :: BuiltinBuilder genZipWith = genVarArgs genZipWith' @@ -150,7 +154,8 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- 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 <- vhdl_ty tmp_ty + let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty + tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start)) @@ -222,6 +227,73 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- Return the conditional generate part return $ AST.GenerateSm cond_label cond_scheme [] app_concsms +-- | Generate a generate statement for the builtin function "zip" +genZip :: BuiltinBuilder +genZip = genVarArgs genZip' +genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genZip' (Left res) f args@[arg1, arg2] = + let + -- Setup the generate scheme + len = (tfvec_len . Var.varType) res + -- TODO: Use something better than varToString + label = mkVHDLExtId ("zipVector" ++ (varToString res)) + n_id = mkVHDLBasicId "n" + n_expr = idToVHDLExpr n_id + range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1)) + genScheme = AST.ForGn n_id range + resname' = mkIndexedName (varToVHDLName res) n_expr + argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr + argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr + in do + labels <- getFieldLabels (tfvec_elem (Var.varType res)) + let resnameA = mkSelectedName resname' (labels!!0) + let resnameB = mkSelectedName resname' (labels!!1) + let resA_assign = mkUncondAssign (Right resnameA) argexpr1 + let resB_assign = mkUncondAssign (Right resnameB) argexpr2 + -- Return the generate functions + return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]] + +-- | Generate a generate statement for the builtin function "unzip" +genUnzip :: BuiltinBuilder +genUnzip = genVarArgs genUnzip' +genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genUnzip' (Left res) f args@[arg] = + let + -- Setup the generate scheme + len = (tfvec_len . Var.varType) arg + -- TODO: Use something better than varToString + label = mkVHDLExtId ("unzipVector" ++ (varToString res)) + n_id = mkVHDLBasicId "n" + n_expr = idToVHDLExpr n_id + range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1)) + genScheme = AST.ForGn n_id range + resname' = varToVHDLName res + argexpr' = mkIndexedName (varToVHDLName arg) n_expr + in do + reslabels <- getFieldLabels (Var.varType res) + arglabels <- getFieldLabels (tfvec_elem (Var.varType arg)) + let resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr + let resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr + let argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) + let argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1) + let resA_assign = mkUncondAssign (Right resnameA) argexprA + let resB_assign = mkUncondAssign (Right resnameB) argexprB + -- Return the generate functions + return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]] + +genCopy :: BuiltinBuilder +genCopy = genVarArgs genCopy' +genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genCopy' (Left res) f args@[arg] = + let + resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) + (AST.PrimName $ (varToVHDLName arg))] + out_assign = mkUncondAssign (Left res) resExpr + in + return [out_assign] + + + ----------------------------------------------------------------------------- -- Function to generate VHDL for applications ----------------------------------------------------------------------------- @@ -243,7 +315,7 @@ genApplication dst f args = mkassign label arg = let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in mkUncondAssign (Right sel_name) arg - Right _ -> error $ "Generate.genApplication Can't generate dataconstructor application without an original binder" + Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" IdInfo.VanillaGlobal -> 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 @@ -255,15 +327,15 @@ genApplication dst f args = if length args == arg_count then builder dst f args else - error $ "Generate.genApplication Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f + error $ "\nGenerate.genApplication: Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication: Using function from another module that is not a known builtin: " ++ pprString f IdInfo.NotGlobalId -> do signatures <- getA vsSignatures -- This is a local id, so it should be a function whose definition we -- have and which can be turned into a component instantiation. let signature = Maybe.fromMaybe - (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") + (error $ "\nGenerate.genApplication: Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") (Map.lookup f signatures) entity_id = ent_id signature -- TODO: Using show here isn't really pretty, but we'll need some @@ -272,7 +344,7 @@ genApplication dst f args = portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature in return [mkComponentInst label entity_id portmaps] - details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details + details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details ----------------------------------------------------------------------------- -- Functions to generate functions dealing with vectors. @@ -282,7 +354,8 @@ genApplication dst f args = -- element type. Generates -- this function if needed. vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId vectorFunId el_ty fname = do - elemTM <- vhdl_ty el_ty + let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty + elemTM <- vhdl_ty error_msg el_ty -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in -- the VHDLState or something. let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM) @@ -297,7 +370,7 @@ vectorFunId el_ty fname = do Just body -> do modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body) return function_id - Nothing -> error $ "I don't know how to generate vector function " ++ fname + Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname where function_id = mkVHDLExtId fname @@ -316,15 +389,23 @@ genUnconsVectorFuns elemTM vectorTM = , (plusgtId, AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet]) , (emptyId, AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr]) , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet]) - , (copyId, AST.SubProgBody copySpec [AST.SPVD copyVar] [copyExpr]) + , (copynId, AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr]) + , (selId, AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet]) + , (ltplusId, AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet] ) + , (plusplusId, AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet]) + , (lengthTId, AST.SubProgBody lengthTSpec [] [lengthTExpr]) ] where ixPar = AST.unsafeVHDLBasicId "ix" vecPar = AST.unsafeVHDLBasicId "vec" + vec1Par = AST.unsafeVHDLBasicId "vec1" + vec2Par = AST.unsafeVHDLBasicId "vec2" nPar = AST.unsafeVHDLBasicId "n" iId = AST.unsafeVHDLBasicId "i" iPar = iId aPar = AST.unsafeVHDLBasicId "a" + fPar = AST.unsafeVHDLBasicId "f" + sPar = AST.unsafeVHDLBasicId "s" resId = AST.unsafeVHDLBasicId "res" exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec ixPar naturalTM] elemTM @@ -472,10 +553,10 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) (AST.PrimName $ AST.NSimple aPar)]) singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) - copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar naturalTM, + copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM, AST.IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to n-1) := (others => a); - copyVar = + copynVar = AST.VarDec resId (AST.SubtypeIn vectorTM (Just $ AST.ConstraintIndex $ AST.IndexConstraint @@ -485,8 +566,71 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) (AST.PrimName $ AST.NSimple aPar)]) -- return res - copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) - + copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) + selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM, + AST.IfaceVarDec sPar naturalTM, + AST.IfaceVarDec nPar naturalTM, + AST.IfaceVarDec vecPar vectorTM ] vectorTM + -- variable res : fsvec_x (0 to n-1); + selVar = + AST.VarDec resId + (AST.SubtypeIn vectorTM + (Just $ AST.ConstraintIndex $ AST.IndexConstraint + [AST.ToRange (AST.PrimLit "0") + ((AST.PrimName (AST.NSimple nPar)) AST.:-: + (AST.PrimLit "1")) ]) + ) + Nothing + -- 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] + -- res(i) := vec(f+i*s); + selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: + (AST.PrimName (AST.NSimple iId) AST.:*: + AST.PrimName (AST.NSimple sPar)) in + AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:= + (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp])) + -- return res; + selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId)) + ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM, + AST.IfaceVarDec aPar elemTM] vectorTM + -- variable res : fsvec_x (0 to vec'length); + ltplusVar = + 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))])) + Nothing + ltplusExpr = AST.NSimple resId AST.:= + ((AST.PrimName $ AST.NSimple vecPar) AST.:&: + (AST.PrimName $ AST.NSimple aPar)) + ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) + plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM, + AST.IfaceVarDec vec2Par vectorTM] + vectorTM + -- variable res : fsvec_x (0 to vec1'length + vec2'length -1); + plusplusVar = + AST.VarDec resId + (AST.SubtypeIn vectorTM + (Just $ AST.ConstraintIndex $ AST.IndexConstraint + [AST.ToRange (AST.PrimLit "0") + (AST.PrimName (AST.NAttribute $ + AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+: + AST.PrimName (AST.NAttribute $ + AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-: + AST.PrimLit "1")])) + Nothing + plusplusExpr = AST.NSimple resId AST.:= + ((AST.PrimName $ AST.NSimple vec1Par) AST.:&: + (AST.PrimName $ AST.NSimple vec2Par)) + 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)) + ----------------------------------------------------------------------------- -- A table of builtin functions ----------------------------------------------------------------------------- @@ -503,14 +647,21 @@ globalNameTable = Map.fromList , (initId , (1, genFCall ) ) , (takeId , (2, genFCall ) ) , (dropId , (2, genFCall ) ) + , (selId , (4, genFCall ) ) , (plusgtId , (2, genFCall ) ) + , (ltplusId , (2, genFCall ) ) + , (plusplusId , (2, genFCall ) ) , (mapId , (2, genMap ) ) , (zipWithId , (3, genZipWith ) ) , (foldlId , (3, genFoldl ) ) , (foldrId , (3, genFoldr ) ) + , (zipId , (2, genZip ) ) + , (unzipId , (1, genUnzip ) ) , (emptyId , (0, genFCall ) ) , (singletonId , (1, genFCall ) ) - , (copyId , (2, genFCall ) ) + , (copynId , (2, genFCall ) ) + , (copyId , (1, genCopy ) ) + , (lengthTId , (1, genFCall ) ) , (hwxorId , (2, genOperator2 AST.Xor ) ) , (hwandId , (2, genOperator2 AST.And ) ) , (hworId , (2, genOperator2 AST.Or ) )