Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry-packages
icurry
Commits
7fab9490
Commit
7fab9490
authored
Feb 19, 2020
by
Michael Hanus
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Bug fix for lifting nested cases
parent
774b5db3
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
62 additions
and
20 deletions
+62
-20
examples/Lifting.curry
examples/Lifting.curry
+39
-0
src/FlatCurry/CaseLifting.curry
src/FlatCurry/CaseLifting.curry
+22
-19
src/ICurry/Main.curry
src/ICurry/Main.curry
+1
-1
No files found.
examples/Lifting.curry
0 → 100644
View file @
7fab9490
-- 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
src/FlatCurry/CaseLifting.curry
View file @
7fab9490
...
...
@@ -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
&&
lift
Let opts -- lift
let expression by creating new function
| nested
--
lift
nested
let expression
s
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
&&
lift
Free opts -- lift
free declaration by creating new function
| nested
--
lift
nested
free declaration
s
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.
...
...
src/ICurry/Main.curry
View file @
7fab9490
...
...
@@ -30,7 +30,7 @@ testI p =
banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "ICurry Compiler (Version of 1
3
/02/20)"
bannerText = "ICurry Compiler (Version of 1
9
/02/20)"
bannerLine = take (length bannerText) (repeat '=')
main :: IO ()
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment