From: Christiaan Baaij Date: Tue, 23 Jun 2009 12:27:47 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=de5278001659d6673ba90e9b721c665805ce4962;hp=757befa0b3e9765ad3eca2990df8a790e187326c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Do not apply eta expansion to application arguments. --- diff --git a/Adders.hs b/Adders.hs index c438914..3afb82f 100644 --- a/Adders.hs +++ b/Adders.hs @@ -175,6 +175,11 @@ highordtest = \x -> functiontest :: TFVec D4 Bit -> TFVec D5 Bit -> RangedWord D3 -> RangedWord D4 -> (Bit, Bit) functiontest = \v1 v2 i1 i2 -> let r1 = v1!i1 ; r2 = v2!i2 in (r1,r2) +xhwnot x = hwnot x + +maptest :: TFVec D4 Bit -> TFVec D4 Bit +maptest = \v -> let r = map xhwnot v in r + highordtest2 = \a b -> case a of High -> \c d -> d diff --git a/Generate.hs b/Generate.hs index 8053f98..f81d769 100644 --- a/Generate.hs +++ b/Generate.hs @@ -27,10 +27,9 @@ genExprFCall fName args = genMapCall :: Int -- | The length of the vector -> Entity -- | The entity to map - -> AST.VHDLId -- | The input vector - -> AST.VHDLId -- | The output vector + -> [AST.VHDLId] -- | The vectors -> AST.GenerateSm -- | The resulting generate statement -genMapCall len entity arg res = genSm +genMapCall len entity [arg, res] = genSm where label = AST.unsafeVHDLBasicId "mapVector" nPar = AST.unsafeVHDLBasicId "n" @@ -62,7 +61,8 @@ genUnconsVectorFuns elemTM vectorTM = , AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet] , AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet] , AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet] - , AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet] + , AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet] + , AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr] ] where ixPar = AST.unsafeVHDLBasicId "ix" @@ -201,3 +201,12 @@ genUnconsVectorFuns elemTM vectorTM = ((AST.PrimName $ AST.NSimple aPar) AST.:&: (AST.PrimName $ AST.NSimple vecPar)) plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) + emptySpec = AST.Function emptyId [] vectorTM + emptyVar = + AST.VarDec resId + (AST.SubtypeIn vectorTM + (Just $ AST.ConstraintIndex $ AST.IndexConstraint + [AST.ToRange (AST.PrimLit "0") + (AST.PrimLit "-1")])) + Nothing + emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId)) \ No newline at end of file diff --git a/GlobalNameTable.hs b/GlobalNameTable.hs index cf585ea..8d38f6c 100644 --- a/GlobalNameTable.hs +++ b/GlobalNameTable.hs @@ -12,22 +12,24 @@ import VHDLTypes import Constants import Generate -mkGlobalNameTable :: [(String, (Int, [AST.Expr] -> AST.Expr ) )] -> NameTable +mkGlobalNameTable :: [(String, (Int, Builder) )] -> NameTable mkGlobalNameTable = Map.fromList globalNameTable :: NameTable globalNameTable = mkGlobalNameTable - [ ("!" , (2, genExprFCall exId ) ) - , ("replace" , (3, genExprFCall replaceId ) ) - , ("head" , (1, genExprFCall headId ) ) - , ("last" , (1, genExprFCall lastId ) ) - , ("tail" , (1, genExprFCall tailId ) ) - , ("init" , (1, genExprFCall initId ) ) - , ("take" , (2, genExprFCall takeId ) ) - , ("drop" , (2, genExprFCall dropId ) ) - , ("+>" , (2, genExprFCall plusgtId ) ) - , ("hwxor" , (2, genExprOp2 AST.Xor ) ) - , ("hwand" , (2, genExprOp2 AST.And ) ) - , ("hwor" , (2, genExprOp2 AST.Or ) ) - , ("hwnot" , (1, genExprOp1 AST.Not ) ) + [ ("!" , (2, Left $ genExprFCall exId ) ) + , ("replace" , (3, Left $ genExprFCall replaceId ) ) + , ("head" , (1, Left $ genExprFCall headId ) ) + , ("last" , (1, Left $ genExprFCall lastId ) ) + , ("tail" , (1, Left $ genExprFCall tailId ) ) + , ("init" , (1, Left $ genExprFCall initId ) ) + , ("take" , (2, Left $ genExprFCall takeId ) ) + , ("drop" , (2, Left $ genExprFCall dropId ) ) + , ("+>" , (2, Left $ genExprFCall plusgtId ) ) + , ("map" , (2, Right $ genMapCall ) ) + , ("empty" , (0, Left $ genExprFCall emptyId ) ) + , ("hwxor" , (2, Left $ genExprOp2 AST.Xor ) ) + , ("hwand" , (2, Left $ genExprOp2 AST.And ) ) + , ("hwor" , (2, Left $ genExprOp2 AST.Or ) ) + , ("hwnot" , (1, Left $ genExprOp1 AST.Not ) ) ] diff --git a/VHDL.hs b/VHDL.hs index eb45420..a40ad00 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -289,18 +289,31 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do -- It's a global value imported from elsewhere. These can be builtin -- functions. funSignatures <- getA vsNameTable + entSignatures <- getA vsSignatures case (Map.lookup (bndrToString f) funSignatures) of Just (arg_count, builder) -> if length valargs == arg_count then - let - sigs = map (bndrToString.varBndr) valargs - sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs - func = builder sigsNames - src_wform = AST.Wform [AST.WformElem func Nothing] - dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) - assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) - in - return [AST.CSSASm assign] + case builder of + Left funBuilder -> + let + sigs = map (bndrToString.varBndr) valargs + sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs + func = funBuilder sigsNames + src_wform = AST.Wform [AST.WformElem func Nothing] + dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr)) + assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) + in + return [AST.CSSASm assign] + Right genBuilder -> + let + sigs = map (varBndr) valargs + signature = Maybe.fromMaybe + (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!") + (Map.lookup (head sigs) entSignatures) + arg_name = mkVHDLExtId (bndrToString (last sigs)) + dst_name = mkVHDLExtId (bndrToString bndr) + genSm = genBuilder 4 signature [arg_name, dst_name] + in return [AST.CSGSm genSm] else error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 6f6625b..2538158 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -54,8 +54,10 @@ type TypeFunMap = Map.Map OrdType [AST.SubProgBody] -- A map of a Haskell function to a hardware signature type SignatureMap = Map.Map CoreSyn.CoreBndr Entity +type Builder = Either ([AST.Expr] -> AST.Expr) (Int -> Entity -> [AST.VHDLId] -> AST.GenerateSm) + -- A map of a builtin function to VHDL function builder -type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr ) +type NameTable = Map.Map String (Int, Builder ) data VHDLSession = VHDLSession { -- | A map of Core type -> VHDL Type