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;ds=sidebyside;h=6a943c79c8f7d6247e0b3336046b8a41c88e72f1;hp=-c;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 --- 6a943c79c8f7d6247e0b3336046b8a41c88e72f1 diff --combined "c\316\273ash/CLasH/Normalize.hs" index 2e341cf,2fc34c6..31474d5 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@@ -23,6 -23,7 +23,7 @@@ import qualified CoreUtil 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 +34,7 @@@ import Outputable ( showSDoc, ppr, nes 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 +338,56 @@@ inlinenonreptop = everywhere ("inlineno -- 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,26 -431,36 +431,36 @@@ inlinedicttop = everywhere ("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 $ "Applying class selector to dictionary without matching type?\n" ++ pprString expr ++ | 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 case List.elemIndex sel selector_ids of - Nothing -> error $ "Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids + 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 +529,20 @@@ casesimpl expr@(Case scrut b ty [(con, -- 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 +624,7 @@@ caseremove, caseremovetop :: Transfor -- 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 --combined "c\316\273ash/CLasH/VHDL/Constants.hs" index 3b796a2,b9cbb0b..e6381fd --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@@ -3,6 -3,20 +3,20 @@@ module CLasH.VHDL.Constants wher -- 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 -------------- @@@ -264,9 -278,6 +278,9 @@@ boolOrId = "|| boolAndId :: String boolAndId = "&&" +boolNot :: String +boolNot = "not" + -- Numeric Operations -- | plus operation identifier @@@ -379,4 -390,4 +393,4 @@@ stringTM = AST.unsafeVHDLBasicId "strin -- | tup VHDLName suffix tupVHDLSuffix :: AST.VHDLId -> AST.Suffix - tupVHDLSuffix id = AST.SSimple id + tupVHDLSuffix id = AST.SSimple id diff --combined "c\316\273ash/CLasH/VHDL/Generate.hs" index fd26365,61e95b4..2258d97 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@@ -584,7 -584,9 +584,7 @@@ genMap (Left res) f [Left mapped_f, Lef genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name genZipWith :: BuiltinBuilder -genZipWith = genVarArgs genZipWith' -genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do { +genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do { -- Setup the generate scheme ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res -- TODO: Use something better than varToString @@@ -596,12 -598,10 +596,12 @@@ -- Create the content of the generate statement: Applying the zipped_f to -- each of the elements in arg1 and arg2, storing to each element in res ; resname = mkIndexedName (varToVHDLName res) n_expr + ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f + ; valargs = get_val_args (Var.varType real_f) already_mapped_args ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr } ; - ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2] + ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2]) -- Return the generate functions ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used) } @@@ -814,15 -814,15 +814,15 @@@ genUnzip' (Left res) f args@[arg] = d _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype genCopy :: BuiltinBuilder -genCopy = genNoInsts $ genVarArgs genCopy' -genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [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] +genCopy = genNoInsts genCopy' +genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm] +genCopy' (Left res) f [arg] = do { + ; [arg'] <- argsToVHDLExprs [arg] + ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg'] + ; out_assign = mkUncondAssign (Left res) resExpr + } + ; return [out_assign] + } genConcat :: BuiltinBuilder genConcat = genNoInsts $ genVarArgs genConcat' @@@ -1554,7 -1554,8 +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 ) ) @@@ -1603,7 -1604,6 +1604,7 @@@ , (gteqId , (2, genOperator2 (AST.:>=:) ) ) , (boolOrId , (2, genOperator2 AST.Or ) ) , (boolAndId , (2, genOperator2 AST.And ) ) + , (boolNot , (1, genOperator1 AST.Not ) ) , (plusId , (2, genOperator2 (AST.:+:) ) ) , (timesId , (2, genTimes ) ) , (negateId , (1, genNegation ) )