From: Christiaan Baaij Date: Thu, 25 Mar 2010 08:52:36 +0000 (+0100) Subject: Merge branch 'master' of http://git.stderr.nl/matthijs/master-project/cλash X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=6a943c79c8f7d6247e0b3336046b8a41c88e72f1;hp=e9462bb7914eb28bea85f13383e0224802187fda;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'master' of git.stderr.nl/matthijs/master-project/cλash Conflicts: cλash/CLasH/Normalize.hs cλash/CLasH/Normalize/NormalizeTools.hs --- diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 2e341cf..31474d5 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -23,6 +23,7 @@ import qualified CoreUtils import qualified Type import qualified Id import qualified Var +import qualified Name import qualified VarSet import qualified CoreFVs import qualified Class @@ -33,6 +34,7 @@ import Outputable ( showSDoc, ppr, nest ) import CLasH.Normalize.NormalizeTypes import CLasH.Translator.TranslatorTypes import CLasH.Normalize.NormalizeTools +import CLasH.VHDL.Constants (builtinIds) import qualified CLasH.Utils as Utils import CLasH.Utils.Core.CoreTools import CLasH.Utils.Core.BinderTools @@ -336,36 +338,56 @@ inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . is -- doesn't seem to set all those names as "system names", we apply some -- guessing here. inlinetoplevel, inlinetopleveltop :: Transform +-- HACK: Don't inline == and /=. The default (derived) implementation +-- for /= uses the polymorphic version of ==, which gets a dictionary +-- for Eq passed in, which contains a reference to itself, resulting in +-- an infinite loop in transformation. Not inlining == is really a hack, +-- but for now it keeps things working with the most common symptom of +-- this problem. +inlinetoplevel expr@(Var f) | Name.getOccString f `elem` ["==", "/="] = return expr -- Any system name is candidate for inlining. Never inline user-defined -- functions, to preserve structure. inlinetoplevel expr@(Var f) | not $ isUserDefined f = do - norm_maybe <- Trans.lift $ getNormalized_maybe f - case norm_maybe of - -- No body or not normalizeable. - Nothing -> return expr - Just norm -> if needsInline norm then do + body_maybe <- needsInline f + case body_maybe of + Just body -> do -- Regenerate all uniques in the to-be-inlined expression - norm_uniqued <- Trans.lift $ genUniques norm + body_uniqued <- Trans.lift $ genUniques body -- And replace the variable reference with the unique'd body. - change norm_uniqued - else + change body_uniqued -- No need to inline - return expr + Nothing -> return expr + -- Leave all other expressions unchanged inlinetoplevel expr = return expr inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel) - -needsInline :: CoreExpr -> Bool -needsInline expr = case splitNormalized expr of - -- Inline any function that only has a single definition, it is probably - -- simple enough. This might inline some stuff that it shouldn't though it - -- will never inline user-defined functions (inlinetoplevel only tries - -- system names) and inlining should never break things. - (args, [bind], res) -> True - _ -> False - - + +-- | Does the given binder need to be inlined? If so, return the body to +-- be used for inlining. +needsInline :: CoreBndr -> TransformMonad (Maybe CoreExpr) +needsInline f = do + body_maybe <- Trans.lift $ getGlobalBind f + case body_maybe of + -- No body available? + Nothing -> return Nothing + Just body -> case CoreSyn.collectArgs body of + -- The body is some (top level) binder applied to 0 or more + -- arguments. That should be simple enough to inline. + (Var f, args) -> return $ Just body + -- Body is more complicated, try normalizing it + _ -> do + norm_maybe <- Trans.lift $ getNormalized_maybe f + case norm_maybe of + -- Noth normalizeable + Nothing -> return Nothing + Just norm -> case splitNormalized norm of + -- The function has just a single binding, so that's simple + -- enough to inline. + (args, [bind], res) -> return $ Just norm + -- More complicated function, don't inline + _ -> return Nothing + -------------------------------- -- Dictionary inlining -------------------------------- @@ -409,14 +431,21 @@ inlinedicttop = everywhere ("inlinedict", inlinedict) -- argument) correspond exactly to this list, we then look up baz in -- that list and replace the entire expression by the corresponding -- argument to D:Baz. +-- +-- We don't resolve methods that have a builtin translation (such as +-- ==), since the actual implementation is not always (easily) +-- translateable. For example, when deriving ==, GHC generates code +-- using $con2tag functions to translate a datacon to an int and compare +-- that with GHC.Prim.==# . Better to avoid that for now. classopresolution, classopresolutiontop :: Transform -classopresolution expr@(App (App (Var sel) ty) dict) = +classopresolution expr@(App (App (Var sel) ty) dict) | not is_builtin = case Id.isClassOpId_maybe sel of -- Not a class op selector Nothing -> return expr Just cls -> case collectArgs dict of (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet) - (dictdc, (ty':selectors)) | tyargs_neq ty ty' -> error $ "Normalize.classopresolution: Applying class selector to dictionary without matching type?\n" ++ pprString expr + (Var dictdc, (ty':selectors)) | not (Maybe.isJust (Id.isDataConId_maybe dictdc)) -> return expr -- Dictionary is not a datacon yet (but e.g., a top level binder) + | tyargs_neq ty ty' -> error $ "Normalize.classopresolution: Applying class selector to dictionary without matching type?\n" ++ pprString expr | otherwise -> let selector_ids = Class.classSelIds cls in -- Find the selector used in the class' list of selectors @@ -424,11 +453,14 @@ classopresolution expr@(App (App (Var sel) ty) dict) = Nothing -> error $ "Normalize.classopresolution: Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids -- Get the corresponding argument from the dictionary Just n -> change (selectors!!n) + (_, _) -> return expr -- Not applying a variable? Don't touch where -- Compare two type arguments, returning True if they are _not_ -- equal tyargs_neq (Type ty1) (Type ty2) = not $ Type.coreEqType ty1 ty2 tyargs_neq _ _ = True + -- Is this a builtin function / method? + is_builtin = elem (Name.getOccString sel) builtinIds -- Leave all other expressions unchanged classopresolution expr = return expr @@ -497,17 +529,20 @@ casesimpl expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr -- is bound to a new simple selector case statement and for each complex -- expression. We do this only for representable types, to prevent loops with -- inlinenonrep. -casesimpl expr@(Case scrut b ty alts) = do +casesimpl expr@(Case scrut bndr ty alts) | not bndr_used = do (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts let bindings = concat bindingss -- Replace the case with a let with bindings and a case - let newlet = mkNonRecLets bindings (Case scrut b ty alts') + let newlet = mkNonRecLets bindings (Case scrut bndr ty alts') -- If there are no non-wild binders, or this case is already a simple -- selector (i.e., a single alt with exactly one binding), already a simple -- selector altan no bindings (i.e., no wild binders in the original case), -- don't change anything, otherwise, replace the case. if null bindings then return expr else change newlet where + -- Check if the scrutinee binder is used + is_used (_, _, expr) = expr_uses_binders [bndr] expr + bndr_used = or $ map is_used alts -- Generate a single wild binder, since they are all the same wild = MkCore.mkWildBinder -- Wilden the binders of one alt, producing a list of bindings as a @@ -589,7 +624,7 @@ caseremove, caseremovetop :: Transform -- Replace a useless case by the value of its single alternative caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr -- Find if any of the binders are used by expr - where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr + where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` b:bndrs))) expr -- Leave all other expressions unchanged caseremove expr = return expr -- Perform this transform everywhere diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index ed538cf..b9f4544 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -24,6 +24,7 @@ import qualified Type -- Local imports import CLasH.Normalize.NormalizeTypes import CLasH.Translator.TranslatorTypes +import CLasH.VHDL.Constants (builtinIds) import CLasH.Utils import qualified CLasH.Utils.Core.CoreTools as CoreTools import qualified CLasH.VHDL.VHDLTools as VHDLTools @@ -45,8 +46,8 @@ applyboth first (name, second) expr = do -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") changed then - -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ - -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ + -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n" + -- ++ "Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ applyboth first (name, second) expr'' else @@ -195,34 +196,11 @@ is_local_var _ = return False isUserDefined :: CoreSyn.CoreBndr -> Bool -- System names are certain to not be user defined isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False --- Check a list of typical compiler-defined names -isUserDefined bndr = str `notElem` (compiler_names ++ builtin_names) +-- Builtin functions are usually not user-defined either (and would +-- break currently if they are...) +isUserDefined bndr = str `notElem` builtinIds where str = Name.getOccString bndr - -- These are names of bindings usually generated by the compiler. For some - -- reason these are not marked as system, probably because the name itself - -- is not made up by the compiler, just this particular binding is. - compiler_names = ["fromInteger"] - builtin_names = [ "!", "replace", "head", "last", "tail", "take", "drop" - , "select", "+>", "<+", "++", "map", "zipWith", "foldl" - , "foldr", "zip", "unzip", "shiftl", "shiftr", "rotl" - , "rotr", "concat", "reverse", "iteraten", "iterate" - , "generaten", "generate", "empty", "singleton", "copyn" - , "copy", "lengthT", "null", "hwxor", "hwand", "hwor" - , "hwnot", "not", "+", "*", "-", "fromSizedWord" - , "resizeWord", "resizeInt", "fst", "snd", "blockRAM" - , "split", "==", "/=", "init" - ] - - -- , (ltId , (2, genOperator2 (AST.:<:) ) ) - -- , (lteqId , (2, genOperator2 (AST.:<=:) ) ) - -- , (gtId , (2, genOperator2 (AST.:>:) ) ) - -- , (gteqId , (2, genOperator2 (AST.:>=:) ) ) - -- , (boolOrId , (2, genOperator2 AST.Or ) ) - -- , (boolAndId , (2, genOperator2 AST.And ) ) - -- , (negateId , (1, genNegation ) ) - -- , (sizedIntId , (1, genSizedInt ) ) - -- , (smallIntegerId , (1, genFromInteger ) ) -- Is the given binder normalizable? This means that its type signature can be -- represented in hardware, which should (?) guarantee that it can be made diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index 3b796a2..e6381fd 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -3,6 +3,20 @@ module CLasH.VHDL.Constants where -- VHDL Imports import qualified Language.VHDL.AST as AST +-- | A list of all builtin functions. Partly duplicates the name table +-- in VHDL.Generate, but we can't use that map everywhere due to +-- circular dependencie. +builtinIds = [ exId, replaceId, headId, lastId, tailId, initId, takeId, dropId + , selId, plusgtId, ltplusId, plusplusId, mapId, zipWithId, foldlId + , foldrId, zipId, unzipId, shiftlId, shiftrId, rotlId, rotrId + , concatId, reverseId, iteratenId, iterateId, generatenId, generateId + , emptyId, singletonId, copynId, copyId, lengthTId, nullId + , hwxorId, hwandId, hworId, hwnotId, equalityId, inEqualityId, ltId + , lteqId, gtId, gteqId, boolOrId, boolAndId, plusId, timesId + , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId + , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId + , splitId, minimumId + ] -------------- -- Identifiers -------------- @@ -379,4 +393,4 @@ stringTM = AST.unsafeVHDLBasicId "string" -- | tup VHDLName suffix tupVHDLSuffix :: AST.VHDLId -> AST.Suffix -tupVHDLSuffix id = AST.SSimple id \ No newline at end of file +tupVHDLSuffix id = AST.SSimple id diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index fd26365..2258d97 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -1554,7 +1554,8 @@ type BuiltinBuilder = type NameTable = Map.Map String (Int, BuiltinBuilder ) -- | The builtin functions we support. Maps a name to an argument count and a --- builder function. +-- builder function. If you add a name to this map, don't forget to add +-- it to VHDL.Constants/builtinIds as well. globalNameTable :: NameTable globalNameTable = Map.fromList [ (exId , (2, genFCall True ) )