Commit 7fab9490 authored by Michael Hanus 's avatar Michael Hanus

Bug fix for lifting nested cases

parent 774b5db3
-- Examples to test lifting
-- Without option --nolifting, a new auxiliary function is generated
zip :: [a] -> [b] -> [(a,b)]
zip [] _ = []
zip (_:_) [] = []
zip (x:xs) (y:ys) = (x,y) : zip xs ys
id :: a -> a
id x = x
-- Without option --nolifting, a new auxiliary function is generated
-- for the non-variable case argument.
complexCase :: Bool -> Bool
complexCase x = case id x of True -> True
False -> False
-- The inner case expression must be lifted
head :: [a] -> a
head xs = id (case xs of x:_ -> x)
-- The inner let declaration must be lifted
ones :: [Int]
ones = id (let xs = 1 : xs in xs)
-- The inner free declaration must be lifted
freevar :: a
freevar = id (let x free in x)
-- The case need not be lifted (although the current ICurry compiler does it)
letCase :: [a] -> Bool
letCase xs = let z = id False
in case xs of [] -> z
_:ys -> letCase ys
freeCase :: [a] -> b
freeCase xs = let z free
in case xs of [] -> z
_:ys -> freeCase ys
......@@ -22,18 +22,16 @@ import FlatCurry.Types
data LiftOptions = LiftOptions
{ liftCase :: Bool -- lift nested cases?
, liftCArg :: Bool -- lift non-variable case arguments?
, liftLet :: Bool -- lift nested lets?
, liftFree :: Bool -- lift nested free declarations?
, currFun :: QName -- name of current function to be lifted (internally used)
}
--- Default options for lifting all nested case/let/free expressions.
defaultLiftOpts :: LiftOptions
defaultLiftOpts = LiftOptions True True True True ("","")
defaultLiftOpts = LiftOptions True True ("","")
--- Default options for lifting no nested case/let/free expression.
defaultNoLiftOpts :: LiftOptions
defaultNoLiftOpts = LiftOptions False False False False ("","")
defaultNoLiftOpts = LiftOptions False False ("","")
-- Add suffix to case function
addSuffix2Fun :: LiftOptions -> String -> LiftOptions
......@@ -43,12 +41,12 @@ addSuffix2Fun opts suff =
------------------------------------------------------------------------------
--- Lift all nested cases in a FlatCurry program.
--- Lift nested cases/lets/free in a FlatCurry program (w.r.t. options).
liftProg :: LiftOptions -> Prog -> Prog
liftProg opts (Prog mn imps types funs ops) =
Prog mn imps types (concatMap (liftFun opts) funs) ops
--- Lift all nested cases in a FlatCurry function.
--- Lift nested cases/lets/free in a FlatCurry function (w.r.t. options).
liftFun :: LiftOptions -> FuncDecl -> [FuncDecl]
liftFun opts (Func fn ar vis texp rule) =
let (nrule, nfs) = liftRule opts { currFun = fn } rule
......@@ -61,11 +59,15 @@ liftRule opts (Rule args rhs) =
let (nrhs, nfs) = liftExp opts False rhs
in (Rule args nrhs, nfs)
-- Lift nested cases/lets/free in expressions.
-- If the second argument is `True`, we are inside an expression where
-- lifting is necessary (e.g., in arguments of function calls).
liftExp :: LiftOptions -> Bool -> Expr -> (Expr, [FuncDecl])
liftExp _ _ (Var v) = (Var v, [])
liftExp _ _ (Lit l) = (Lit l, [])
liftExp opts _ (Comb ct qn es) =
let (nes,nfs) = unzip (map (\ (n,e) -> liftExpArg opts n e) (zip [1..] es))
let (nes,nfs) = unzip (map (\ (n,e) -> liftExpArg opts True n e)
(zip [1..] es))
in (Comb ct qn nes, concat nfs)
liftExp opts nested exp@(Case ct e brs) = case e of
......@@ -73,19 +75,19 @@ liftExp opts nested exp@(Case ct e brs) = case e of
_ -> if liftCArg opts then liftCaseArg else liftCaseExp
where
liftCaseExp =
if nested && liftCase opts -- lift case expression by creating new function
if nested -- lift case expression by creating new function
then let vs = unboundVars exp
cfn = currFun (addSuffix2Fun opts "$CASE")
noneType = TCons ("Prelude","None") []
caseFunc = Func cfn (length vs) Private noneType (Rule vs exp)
in (Comb FuncCall cfn (map Var vs), liftFun opts caseFunc)
else let (ne, nefs) = liftExpArg opts 0 e
else let (ne, nefs) = liftExpArg opts True 0 e
(nbrs, nfs) = unzip (map (liftBranch opts) (zip [1..] brs))
in (Case ct ne nbrs, nefs ++ concat nfs)
-- lift case with complex (non-variable) case argument:
liftCaseArg =
let (ne, nefs) = liftExpArg opts 0 e
let (ne, nefs) = liftExpArg opts True 0 e
casevar = maximum (0 : allVars exp) + 1
vs = unionMap unboundVarsInBranch brs
cfn = currFun (addSuffix2Fun opts "$COMPLEXCASE")
......@@ -95,20 +97,20 @@ liftExp opts nested exp@(Case ct e brs) = case e of
in (Comb FuncCall cfn (map Var vs ++ [ne]), nefs ++ liftFun opts caseFunc)
liftExp opts nested exp@(Let bs e)
| nested && liftLet opts -- lift let expression by creating new function
| nested -- lift nested let expressions by creating new function
= let vs = unboundVars exp
cfn = currFun (addSuffix2Fun opts "$LET")
noneType = TCons ("Prelude","None") []
letFunc = Func cfn (length vs) Private noneType (Rule vs exp)
in (Comb FuncCall cfn (map Var vs), liftFun opts letFunc)
| otherwise
= let (nes,nfs1) = unzip (map (\ (n,be) -> liftExpArg opts n be)
= let (nes,nfs1) = unzip (map (\ (n,be) -> liftExpArg opts True n be)
(zip [1..] (map snd bs)))
(ne,nfs2) = liftExpArg opts 0 e
(ne,nfs2) = liftExpArg opts True 0 e
in (Let (zip (map fst bs) nes) ne, concat nfs1 ++ nfs2)
liftExp opts nested exp@(Free vs e)
| nested && liftFree opts -- lift free declaration by creating new function
| nested -- lift nested free declarations by creating new function
= let fvs = unboundVars exp
cfn = currFun (addSuffix2Fun opts "$FREE")
noneType = TCons ("Prelude","None") []
......@@ -119,8 +121,8 @@ liftExp opts nested exp@(Free vs e)
in (Free vs ne, nfs)
liftExp opts _ (Or e1 e2) =
let (ne1, nfs1) = liftExpArg opts 1 e1
(ne2, nfs2) = liftExpArg opts 2 e2
let (ne1, nfs1) = liftExpArg opts True 1 e1
(ne2, nfs2) = liftExpArg opts True 2 e2
in (Or ne1 ne2, nfs1 ++ nfs2)
liftExp opts nested (Typed e te) =
let (ne, nfs) = liftExp opts nested e
......@@ -128,12 +130,13 @@ liftExp opts nested (Typed e te) =
-- Lift an argument of an expression so that the argument number
-- is added to the case function in order to obtain unique names.
liftExpArg :: LiftOptions -> Int -> Expr -> (Expr, [FuncDecl])
liftExpArg opts argnum = liftExp (addSuffix2Fun opts ('_' : show argnum)) True
liftExpArg :: LiftOptions -> Bool -> Int -> Expr -> (Expr, [FuncDecl])
liftExpArg opts nested argnum =
liftExp (addSuffix2Fun opts ('_' : show argnum)) nested
liftBranch :: LiftOptions -> (Int,BranchExpr) -> (BranchExpr, [FuncDecl])
liftBranch opts (bnum, Branch pat e) =
let (ne,nfs) = liftExpArg opts bnum e
let (ne,nfs) = liftExpArg opts (liftCase opts) bnum e
in (Branch pat ne, nfs)
--- Find all variables which are not bound in an expression.
......
......@@ -30,7 +30,7 @@ testI p =
banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "ICurry Compiler (Version of 13/02/20)"
bannerText = "ICurry Compiler (Version of 19/02/20)"
bannerLine = take (length bannerText) (repeat '=')
main :: IO ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment