-- transformation ensures that the lambda abstractions always contain a
-- recursive let and that, when the return value is representable, the
-- let contains a local variable reference in its body.
+retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
+ local_var <- Trans.lift $ is_local_var expr
+ repr <- isRepr expr
+ if not local_var && repr
+ then do
+ id <- Trans.lift $ mkBinderFor expr "res"
+ change $ Let (Rec [(id, expr)]) (Var id)
+ else
+ return expr
+
retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do
-- Don't extract values that are already a local variable, to prevent
-- loops with ourselves.
else
return expr
-retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
- local_var <- Trans.lift $ is_local_var expr
- repr <- isRepr expr
- if not local_var && repr
- then do
- id <- Trans.lift $ mkBinderFor expr "res"
- change $ Let (Rec [(id, expr)]) (Var id)
- else
- return expr
-- Leave all other expressions unchanged
retvalsimpl c expr = return expr
(Var f, args) -> return $ Just body
-- Body is more complicated, try normalizing it
_ -> do
- norm_maybe <- Trans.lift $ getNormalized_maybe f
+ norm_maybe <- Trans.lift $ getNormalized_maybe False f
case norm_maybe of
-- Noth normalizeable
Nothing -> return Nothing
- Just norm -> case splitNormalized norm of
+ Just norm -> case splitNormalizedNonRep norm of
-- The function has just a single binding, so that's simple
-- enough to inline.
- (args, [bind], res) -> return $ Just norm
+ (args, [bind], Var res) -> return $ Just norm
-- More complicated function, don't inline
_ -> return Nothing
-- inlinenonrep).
if (not wild) && repr
then do
- -- Create on new binder that will actually capture a value in this
+ caseexpr <- Trans.lift $ mkSelCase scrut i
+ -- Create a new binder that will actually capture a value in this
-- case statement, and return it.
- let bty = (Id.idType b)
- id <- Trans.lift $ mkInternalVar "sel" bty
- let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
- let caseexpr = Case scrut b bty [(con, binders, Var id)]
return (wildbndrs!!i, Just (b, caseexpr))
else
-- Just leave the original binder in place, and don't generate an
-- | 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
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The function to get
-> TranslatorSession CoreExpr -- The normalized function body
-getNormalized bndr = do
- norm <- getNormalized_maybe bndr
+getNormalized result_nonrep bndr = do
+ norm <- getNormalized_maybe result_nonrep bndr
return $ Maybe.fromMaybe
(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 or is not normalizeable.
getNormalized_maybe ::
- CoreBndr -- ^ The function to get
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The function to get
-> TranslatorSession (Maybe CoreExpr) -- The normalized function body
-getNormalized_maybe bndr = do
+getNormalized_maybe result_nonrep bndr = do
expr_maybe <- getGlobalBind bndr
- normalizeable <- isNormalizeable' bndr
+ normalizeable <- isNormalizeable result_nonrep bndr
if not normalizeable || Maybe.isNothing expr_maybe
then
-- Binder not normalizeable or 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)
+ 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 ::
return expr'
-- | Split a normalized expression into the argument binders, top level
--- bindings and the result binder.
+-- bindings and the result binder. This function returns an error if
+-- the type of the expression is not representable.
splitNormalized ::
CoreExpr -- ^ The normalized expression
-> ([CoreBndr], [Binding], CoreBndr)
-splitNormalized expr = (args, binds, res)
+splitNormalized expr =
+ case splitNormalizedNonRep expr of
+ (args, binds, Var res) -> (args, binds, res)
+ _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
+
+-- Split a normalized expression, whose type can be unrepresentable.
+splitNormalizedNonRep::
+ CoreExpr -- ^ The normalized expression
+ -> ([CoreBndr], [Binding], CoreExpr)
+splitNormalizedNonRep expr = (args, binds, resexpr)
where
(args, letexpr) = CoreSyn.collectBinders expr
(binds, resexpr) = flattenLets letexpr
- res = case resexpr of
- (Var x) -> x
- _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"