X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=20d3ac85d778f649c04e17d0219fc59ee78a8542;hb=3bb8c684038e01d1b8c3db13d9a57b1f0fd99925;hp=d6acc13b19dbc82e37ffaa08195421c63e1f4e52;hpb=118a85a1ad01d78cf9e4a2e63d0f7b4f35bb8a1f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index d6acc13..20d3ac8 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -782,11 +782,11 @@ argproptop = everywhere ("argprop", argprop) -------------------------------- -- Non-representable result inlining -------------------------------- --- This transformation takes a function that has a non-representable --- result (e.g., a tuple containing a function, or an Integer. The --- latter can occur in some cases as the result of the fromIntegerT --- function) and inlines enough of the function to make the result --- representable again. +-- This transformation takes a function (top level binding) that has a +-- non-representable result (e.g., a tuple containing a function, or an +-- Integer. The latter can occur in some cases as the result of the +-- fromIntegerT function) and inlines enough of the function to make the +-- result representable again. -- -- This is done by first normalizing the function and then "inlining" -- the result. Since no unrepresentable let bindings are allowed in @@ -797,6 +797,12 @@ argproptop = everywhere ("argprop", argprop) -- -- The new function result will be a tuple containing all free variables -- of the old result, so the old result can be rebuild at the caller. +-- +-- We take care not to inline dictionary id's, which are top level +-- bindings with a non-representable result type as well, since those +-- will never become VHDL signals directly. There is a separate +-- transformation (inlinedict) that specifically inlines dictionaries +-- only when it is useful. inlinenonrepresult, inlinenonrepresulttop :: Transform -- Apply to any (application of) a reference to a top level function @@ -805,7 +811,7 @@ inlinenonrepresult, inlinenonrepresulttop :: Transform -- expressions are generally left alone and can occur anywhere. inlinenonrepresult context expr | not (is_fun expr) = case collectArgs expr of - (Var f, args) -> do + (Var f, args) | not (Id.isDictId f) -> do repr <- isRepr expr if not repr then do @@ -813,50 +819,58 @@ inlinenonrepresult context expr | not (is_fun expr) = case body_maybe of Just body -> do let (bndrs, binds, res) = splitNormalizedNonRep body - -- Get the free local variables of res - global_bndrs <- Trans.lift getGlobalBinders - let interesting var = Var.isLocalVar var && (var `notElem` global_bndrs) - let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting res - let free_var_types = map Id.idType free_vars - let n_free_vars = length free_vars - -- Get a tuple datacon to wrap around the free variables - let fvs_datacon = TysWiredIn.tupleCon BasicTypes.Boxed n_free_vars - let fvs_datacon_id = DataCon.dataConWorkId fvs_datacon - -- Let the function now return a tuple with references to - -- all free variables of the old return value. First pass - -- all the types of the variables, since tuple - -- constructors are polymorphic. - let newres = mkApps (Var fvs_datacon_id) (map Type free_var_types ++ map Var free_vars) - -- Recreate the function body with the changed return value - let newbody = mkLams bndrs (Let (Rec binds) newres) - -- Create the new function - f' <- Trans.lift $ mkFunction f newbody - - -- Call the new function - let newapp = mkApps (Var f') args - res_bndr <- Trans.lift $ mkBinderFor newapp "res" - -- Create extractor case expressions to extract each of the - -- free variables from the tuple. - sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1] - - -- Bind the res_bndr to the result of the new application - -- and each of the free variables to the corresponding - -- selector case. Replace the let body with the original - -- body of the called function (which can still access all - -- of its free variables, from the let). - let binds = (res_bndr, newapp):(zip free_vars sel_cases) - let letexpr = Let (Rec binds) res - - -- Finally, regenarate all uniques in the new expression, - -- since the free variables could otherwise become - -- duplicated. It is not strictly necessary to regenerate - -- res, since we're moving that expression, but it won't - -- hurt. - letexpr_uniqued <- Trans.lift $ genUniques letexpr - change letexpr_uniqued + if has_free_tyvars res + then + -- Don't touch anything with free type variables, since + -- we can't return those. We'll wait until argprop + -- removed those variables. + return expr + else do + -- Get the free local variables of res + global_bndrs <- Trans.lift getGlobalBinders + let interesting var = Var.isLocalVar var && (var `notElem` global_bndrs) + let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting res + let free_var_types = map Id.idType free_vars + let n_free_vars = length free_vars + -- Get a tuple datacon to wrap around the free variables + let fvs_datacon = TysWiredIn.tupleCon BasicTypes.Boxed n_free_vars + let fvs_datacon_id = DataCon.dataConWorkId fvs_datacon + -- Let the function now return a tuple with references to + -- all free variables of the old return value. First pass + -- all the types of the variables, since tuple + -- constructors are polymorphic. + let newres = mkApps (Var fvs_datacon_id) (map Type free_var_types ++ map Var free_vars) + -- Recreate the function body with the changed return value + let newbody = mkLams bndrs (Let (Rec binds) newres) + -- Create the new function + f' <- Trans.lift $ mkFunction f newbody + + -- Call the new function + let newapp = mkApps (Var f') args + res_bndr <- Trans.lift $ mkBinderFor newapp "res" + -- Create extractor case expressions to extract each of the + -- free variables from the tuple. + sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1] + + -- Bind the res_bndr to the result of the new application + -- and each of the free variables to the corresponding + -- selector case. Replace the let body with the original + -- body of the called function (which can still access all + -- of its free variables, from the let). + let binds = (res_bndr, newapp):(zip free_vars sel_cases) + let letexpr = Let (Rec binds) res + + -- Finally, regenarate all uniques in the new expression, + -- since the free variables could otherwise become + -- duplicated. It is not strictly necessary to regenerate + -- res, since we're moving that expression, but it won't + -- hurt. + letexpr_uniqued <- Trans.lift $ genUniques letexpr + change letexpr_uniqued Nothing -> return expr else - -- Don't touch representable expressions + -- Don't touch representable expressions or (applications of) + -- dictionary ids. return expr -- Not a reference to or application of a top level function _ -> return expr