From 254a259d6cfa363ac4da8c69b665ce4ce2a29ee7 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 3 Mar 2010 13:30:44 +0100 Subject: [PATCH 01/16] Use fromMaybe with an error message instead of fromJust. --- "c\316\273ash/CLasH/VHDL/Generate.hs" | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 1d8194d..afd1741 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -172,9 +172,13 @@ mkStateProcSm :: mkStateProcSm (old, new, res) = do let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old) - let type_mark_old = Maybe.fromJust type_mark_old_maybe + let type_mark_old = Maybe.fromMaybe + (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old)) + type_mark_old_maybe type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res) - let type_mark_res' = Maybe.fromJust type_mark_res_maybe + let type_mark_res' = Maybe.fromMaybe + (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res)) + type_mark_res_maybe let type_mark_res = if type_mark_old == type_mark_res' then type_mark_res' else -- 2.30.2 From 7c8bb43c572704c4afb86bdaf917c1a695009378 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 3 Mar 2010 14:05:19 +0100 Subject: [PATCH 02/16] Allow inlining of head and friends. --- "c\316\273ash/CLasH/Normalize/NormalizeTools.hs" | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index c67b9e1..187c6f9 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -199,7 +199,7 @@ isUserDefined bndr = str `notElem` compiler_names -- 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", "+", "*", "-", "!"] + compiler_names = ["fromInteger", "head", "tail", "init", "last", "+", "*", "-", "!"] -- Is the given binder normalizable? This means that its type signature can be -- represented in hardware, which should (?) guarantee that it can be made -- 2.30.2 From c39649cd42d2ef3bc2105b19356aa97b4913a540 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 3 Mar 2010 14:05:33 +0100 Subject: [PATCH 03/16] Support stateful functions with no own state (only substate). --- "c\316\273ash/CLasH/VHDL/Generate.hs" | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index afd1741..a9947a2 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -134,8 +134,14 @@ getArchitecture fname = makeCached fname tsArchitectures $ do (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of ([in_state], [out_state], Nothing) -> do nonEmpty <- hasNonEmptyType in_state - if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[]) - ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval) + if nonEmpty + then error ("No initial state defined for: " ++ show fname) + else return ([],[]) + ([in_state], [out_state], Just resetval) -> do + nonEmpty <- hasNonEmptyType in_state + if nonEmpty + then mkStateProcSm (in_state, out_state, resetval) + else error ("Initial state defined for function with only substate: " ++ show fname) ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname ([], [], Nothing) -> return ([],[]) (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs -- 2.30.2 From 729463aa72a83323564e39a608a68d02412af2c1 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 5 Mar 2010 17:29:02 +0100 Subject: [PATCH 04/16] Remove getBinding and use getGlobalBind instead. --- "c\316\273ash/CLasH/Normalize.hs" | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 538b60d..5690589 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -738,7 +738,7 @@ getNormalized bndr = Utils.makeCached bndr tsNormalized $ -- a different error if this happens down in the recursion. error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" else do - expr <- getBinding bndr + Just expr <- getGlobalBind bndr normalizeExpr (show bndr) expr -- | Normalize an expression @@ -755,17 +755,6 @@ normalizeExpr what expr = do trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return () return expr' --- | Get the value that is bound to the given binder at top level. Fails when --- there is no such binding. -getBinding :: - CoreBndr -- ^ The binder to get the expression for - -> TranslatorSession CoreExpr -- ^ The value bound to the binder - -getBinding bndr = Utils.makeCached bndr tsBindings $ - -- If the binding isn't in the "cache" (bindings map), then we can't create - -- it out of thin air, so return an error. - error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr - -- | Split a normalized expression into the argument binders, top level -- bindings and the result binder. splitNormalized :: -- 2.30.2 From d59ed8de0b03c0eeba23f5a5e08f3c24b87dc3ab Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 5 Mar 2010 17:54:45 +0100 Subject: [PATCH 05/16] Add getNormalized_maybe that does not fail if a binder was not found. --- "c\316\273ash/CLasH/Normalize.hs" | 42 +++++++++++++++++++++++-------- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 5690589..fa14ef6 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -726,20 +726,40 @@ simplrestop expr = do -- What transforms to run? transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop] --- | Returns the normalized version of the given function. +-- | Returns the normalized version of the given function, or an error +-- if it is not a known global binder. getNormalized :: CoreBndr -- ^ The function to get -> TranslatorSession CoreExpr -- The normalized function body - -getNormalized bndr = Utils.makeCached bndr tsNormalized $ - if is_poly (Var bndr) - then - -- This should really only happen at the top level... TODO: Give - -- a different error if this happens down in the recursion. - error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" - else do - Just expr <- getGlobalBind bndr - normalizeExpr (show bndr) expr +getNormalized bndr = do + norm <- getNormalized_maybe bndr + return $ Maybe.fromMaybe + (error $ "Normalize.getNormalized: Unknown function requested: " ++ show bndr) + norm + +-- | Returns the normalized version of the given function, or Nothing +-- when the binder is not a known global binder. +getNormalized_maybe :: + CoreBndr -- ^ The function to get + -> TranslatorSession (Maybe CoreExpr) -- The normalized function body + +getNormalized_maybe bndr = do + expr_maybe <- getGlobalBind bndr + if Maybe.isNothing expr_maybe + then + -- Binder not found + return Nothing + else if is_poly (Var bndr) + then + -- This should really only happen at the top level... TODO: Give + -- a different error if this happens down in the recursion. + error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize" + else do + -- Binder found and is monomorphic. Normalize the expression + -- and cache the result. + normalized <- Utils.makeCached bndr tsNormalized $ + normalizeExpr (show bndr) (Maybe.fromJust expr_maybe) + return (Just normalized) -- | Normalize an expression normalizeExpr :: -- 2.30.2 From 339dab663321157d33d724846a7cec084b0da81e Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 5 Mar 2010 18:12:51 +0100 Subject: [PATCH 06/16] Add variant of isRepr that operates in the TranslatorSession. --- "c\316\273ash/CLasH/Normalize/NormalizeTools.hs" | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 187c6f9..3da2728 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -178,9 +178,12 @@ substitute_clone find repl expr = subeverywhere (substitute_clone find repl) exp -- Is the given expression representable at runtime, based on the type? isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool -isRepr tything = case CoreTools.getType tything of +isRepr tything = Trans.lift (isRepr' tything) + +isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool +isRepr' tything = case CoreTools.getType tything of Nothing -> return False - Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty + Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool is_local_var (CoreSyn.Var v) = do -- 2.30.2 From 7eed9f7f33ef0a7b8ac307af9249a379692dd21d Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 5 Mar 2010 18:14:45 +0100 Subject: [PATCH 07/16] Add variant of isNormalizeable that operates in the TranslatorSession. --- "c\316\273ash/CLasH/Normalize/NormalizeTools.hs" | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 3da2728..7a187f8 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -209,9 +209,12 @@ isUserDefined bndr = str `notElem` compiler_names -- into hardware. Note that if a binder is not normalizable, it might become -- so using argument propagation. isNormalizeable :: CoreBndr -> TransformMonad Bool -isNormalizeable bndr = do +isNormalizeable bndr = Trans.lift (isNormalizeable' bndr) + +isNormalizeable' :: CoreBndr -> TranslatorSession Bool +isNormalizeable' bndr = do let ty = Id.idType bndr let (arg_tys, res_ty) = Type.splitFunTys ty -- This function is normalizable if all its arguments and return value are -- representable. - andM $ mapM isRepr (res_ty:arg_tys) + andM $ mapM isRepr' (res_ty:arg_tys) -- 2.30.2 From c499e901a25eb7df0bfac03d57ee3401ad6cb7e7 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 5 Mar 2010 18:15:49 +0100 Subject: [PATCH 08/16] Let getNormalized return Nothing on non-normalizeable functions. --- "c\316\273ash/CLasH/Normalize.hs" | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index fa14ef6..82cc89b 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -734,20 +734,21 @@ getNormalized :: getNormalized bndr = do norm <- getNormalized_maybe bndr return $ Maybe.fromMaybe - (error $ "Normalize.getNormalized: Unknown function requested: " ++ show bndr) + (error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr) norm -- | Returns the normalized version of the given function, or Nothing --- when the binder is not a known global binder. +-- when the binder is not a known global binder or is not normalizeable. getNormalized_maybe :: CoreBndr -- ^ The function to get -> TranslatorSession (Maybe CoreExpr) -- The normalized function body getNormalized_maybe bndr = do expr_maybe <- getGlobalBind bndr - if Maybe.isNothing expr_maybe + normalizeable <- isNormalizeable' bndr + if not normalizeable || Maybe.isNothing expr_maybe then - -- Binder not found + -- Binder not normalizeable or not found return Nothing else if is_poly (Var bndr) then -- 2.30.2 From bb9442c6efb3b7dc6b16d56234e4b064c45bfb75 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 5 Mar 2010 18:20:51 +0100 Subject: [PATCH 09/16] Let inlinetoplevel use getNormalized_maybe. This makes the transformation slightly simpler and prepares it for inlining dictionaries next. --- "c\316\273ash/CLasH/Normalize.hs" | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 82cc89b..91033b5 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -338,23 +338,19 @@ inlinetoplevel, inlinetopleveltop :: Transform -- Any system name is candidate for inlining. Never inline user-defined -- functions, to preserve structure. inlinetoplevel expr@(Var f) | not $ isUserDefined f = do - norm <- isNormalizeable f - -- See if this is a top level binding for which we have a body - body_maybe <- Trans.lift $ getGlobalBind f - if norm && Maybe.isJust body_maybe - then do - -- Get the normalized version - norm <- Trans.lift $ getNormalized f - if needsInline norm - then do - -- Regenerate all uniques in the to-be-inlined expression - norm_uniqued <- Trans.lift $ genUniques norm - change norm_uniqued - else - return expr - else + norm_maybe <- Trans.lift $ getNormalized_maybe f + case norm_maybe of -- No body or not normalizeable. - return expr + Nothing -> return expr + Just norm -> if needsInline norm then do + -- Regenerate all uniques in the to-be-inlined expression + norm_uniqued <- Trans.lift $ genUniques norm + -- And replace the variable reference with the unique'd body. + change norm_uniqued + else + -- No need to inline + return expr + -- Leave all other expressions unchanged inlinetoplevel expr = return expr inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel) -- 2.30.2 From d20ac1165e401bed9991affa47eae14e1a815b25 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 8 Mar 2010 10:49:51 +0100 Subject: [PATCH 10/16] Add dictionary inlining transformation. --- "c\316\273ash/CLasH/Normalize.hs" | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 91033b5..4c04e85 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -364,6 +364,22 @@ needsInline expr = case splitNormalized expr of (args, [bind], res) -> True _ -> False + +-------------------------------- +-- Dictionary inlining +-------------------------------- +-- Inline all top level dictionaries, so we can use them to resolve +-- class methods based on the dictionary passed. +inlinedict expr@(Var f) | Id.isDictId f = do + body_maybe <- Trans.lift $ getGlobalBind f + case body_maybe of + Nothing -> return expr + Just body -> change body + +-- Leave all other expressions unchanged +inlinedict expr = return expr +inlinedicttop = everywhere ("inlinedict", inlinedict) + -------------------------------- -- Scrutinee simplification -------------------------------- @@ -720,7 +736,7 @@ simplrestop expr = do -- What transforms to run? -transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop] +transforms = [inlinedicttop, inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop] -- | Returns the normalized version of the given function, or an error -- if it is not a known global binder. -- 2.30.2 From d00bdb4899f108cbb766260aace1a019919a5283 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 8 Mar 2010 11:35:52 +0100 Subject: [PATCH 11/16] Add class operation resolution transformation. This transformation enables user-defined type classes. --- "c\316\273ash/CLasH/Normalize.hs" | 57 ++++++++++++++++++++++++++++++- 1 file changed, 56 insertions(+), 1 deletion(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 4c04e85..86ade5b 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -25,6 +25,7 @@ import qualified Id import qualified Var import qualified VarSet import qualified CoreFVs +import qualified Class import qualified MkCore import Outputable ( showSDoc, ppr, nest ) @@ -380,6 +381,60 @@ inlinedict expr@(Var f) | Id.isDictId f = do inlinedict expr = return expr inlinedicttop = everywhere ("inlinedict", inlinedict) +-------------------------------- +-- ClassOp resolution +-------------------------------- +-- Resolves any class operation to the actual operation whenever +-- possible. Class methods (as well as parent dictionary selectors) are +-- special "functions" that take a type and a dictionary and evaluate to +-- the corresponding method. A dictionary is nothing more than a +-- special dataconstructor applied to the type the dictionary is for, +-- each of the superclasses and all of the class method definitions for +-- that particular type. Since dictionaries all always inlined (top +-- levels dictionaries are inlined by inlinedict, local dictionaries are +-- inlined by inlinenonrep), we will eventually have something like: +-- +-- baz +-- @ CLasH.HardwareTypes.Bit +-- (D:Baz @ CLasH.HardwareTypes.Bit bitbaz) +-- +-- Here, baz is the method selector for the baz method, while +-- D:Baz is the dictionary constructor for the Baz and bitbaz is the baz +-- method defined in the Baz Bit instance declaration. +-- +-- To resolve this, we can look at the ClassOp IdInfo from the baz Id, +-- which contains the Class it is defined for. From the Class, we can +-- get a list of all selectors (both parent class selectors as well as +-- method selectors). Since the arguments to D:Baz (after the type +-- 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. +classopresolution, classopresolutiontop :: Transform +classopresolution expr@(App (App (Var sel) ty) dict) = + 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 $ "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 + -- Get the corresponding argument from the dictionary + Just n -> change (selectors!!n) + 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 + +-- Leave all other expressions unchanged +classopresolution expr = return expr +-- Perform this transform everywhere +classopresolutiontop = everywhere ("classopresolution", classopresolution) + -------------------------------- -- Scrutinee simplification -------------------------------- @@ -736,7 +791,7 @@ simplrestop expr = do -- What transforms to run? -transforms = [inlinedicttop, inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop] +transforms = [inlinedicttop, inlinetopleveltop, classopresolutiontop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop] -- | Returns the normalized version of the given function, or an error -- if it is not a known global binder. -- 2.30.2 From 829e3b461156a39d30f6796b26a8c83a119bed43 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 8 Mar 2010 11:54:26 +0100 Subject: [PATCH 12/16] Show uniques in listBindings output. --- "c\316\273ash/CLasH/Utils/GhcTools.hs" | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index fc63ac4..d898795 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -35,7 +35,7 @@ listBindings libdir filenames = do listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () listBinding (b, e) = do putStr "\nBinder: " - putStr $ show b + putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]" putStr "\nType of Binder: \n" putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b putStr "\n\nExpression: \n" -- 2.30.2 From eade653c03372e3cc27e502e053b6de7d924eb64 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 8 Mar 2010 11:54:45 +0100 Subject: [PATCH 13/16] Show classes in listBindings output. --- "c\316\273ash/CLasH/Utils/GhcTools.hs" | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index d898795..c407436 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -19,6 +19,7 @@ import qualified Name import qualified Serialized import qualified Var import qualified Outputable +import qualified Class -- Local Imports import CLasH.Utils.Pretty @@ -31,6 +32,9 @@ listBindings libdir filenames = do (cores,_,_) <- loadModules libdir filenames Nothing let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores mapM listBinding binds + putStr "\n=========================\n" + let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores + mapM listClass classes listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () listBinding (b, e) = do @@ -45,6 +49,14 @@ listBinding (b, e) = do putStr "\n\nType of Expression: \n" putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e putStr "\n\n" + +listClass :: Class.Class -> IO () +listClass c = do + putStr "\nClass: " + putStr $ show (Class.className c) + putStr "\nSelectors: " + putStr $ show (Class.classSelIds c) + putStr "\n" -- | Show the core structure of the given binds in the given file. listBind :: FilePath -> [FilePath] -> String -> IO () -- 2.30.2 From dd0b3f0f95a335492533202a5801d7df9edd2762 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Mon, 8 Mar 2010 12:07:27 +0100 Subject: [PATCH 14/16] Make listBindings return IO () instead of IO [()]. The previous type caused ghci to print an extra list of units after the regular output, while it simple ignores the single tuple now. --- "c\316\273ash/CLasH/Utils/GhcTools.hs" | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index c407436..f1fe6ba 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -27,7 +27,7 @@ import CLasH.Translator.TranslatorTypes import CLasH.Translator.Annotations import CLasH.Utils -listBindings :: FilePath -> [FilePath] -> IO [()] +listBindings :: FilePath -> [FilePath] -> IO () listBindings libdir filenames = do (cores,_,_) <- loadModules libdir filenames Nothing let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores @@ -35,6 +35,7 @@ listBindings libdir filenames = do putStr "\n=========================\n" let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores mapM listClass classes + return () listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () listBinding (b, e) = do -- 2.30.2 From b849c09f1b86d2851da13f56cce82bd02d03eb28 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Sat, 20 Mar 2010 16:42:05 +0100 Subject: [PATCH 15/16] Fix zipWith template to work with partially applied functions, add support for boolean negation, and update error message of classopresolution transformation --- "c\316\273ash/CLasH/Normalize.hs" | 4 ++-- "c\316\273ash/CLasH/VHDL/Constants.hs" | 3 +++ "c\316\273ash/CLasH/VHDL/Generate.hs" | 9 +++++---- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 86ade5b..2e341cf 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -416,12 +416,12 @@ classopresolution expr@(App (App (Var sel) ty) dict) = 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 $ "Applying class selector to dictionary without matching type?\n" ++ pprString expr + (dictdc, (ty':selectors)) | 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) where diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index 22bf14a..3b796a2 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -264,6 +264,9 @@ boolOrId = "||" boolAndId :: String boolAndId = "&&" +boolNot :: String +boolNot = "not" + -- Numeric Operations -- | plus operation identifier diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index a9947a2..a6f3590 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -584,9 +584,7 @@ genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do { 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 @@ -598,10 +596,12 @@ genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do { -- 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) } @@ -1603,6 +1603,7 @@ globalNameTable = Map.fromList , (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 ) ) -- 2.30.2 From ba3fc1b305de424187b698b18a5facac799093f4 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Sat, 20 Mar 2010 22:18:43 +0100 Subject: [PATCH 16/16] Move built_in names to different list within NormalizeTools --- .../CLasH/Normalize/NormalizeTools.hs" | 24 +++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 7a187f8..633ac7a 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -196,13 +196,33 @@ 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 +isUserDefined bndr = str `notElem` (compiler_names ++ builtin_names) 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", "head", "tail", "init", "last", "+", "*", "-", "!"] + 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", "==", "/=" + ] + + -- , (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 -- 2.30.2