Commit 59ff4352 authored by Michael Hanus 's avatar Michael Hanus

Case lifter produces shorter and unique names for lifted functions

parent 7fab9490
module Control.Monad.State where
data State s a = State (s -> (a, s))
{-
instance Applicative (State s) where
pure x = State (\s -> (x,s))
(State ff) <*> (State g) = State (\s -> let (f,s1) = ff s
(a,s2) = g s1
result = (f a,s2)
in result)
-}
instance Functor (State s) where
fmap f (State g) = State $ \s -> let (a,s1) = g s in (f a,s1)
instance Monad (State s) where
return x = state (\s -> (x, s))
m >>= f = state (\s -> let (x, s') = runState m s
in runState (f x) s')
runState :: State s a -> (s -> (a,s))
runState (State st) = st
state :: (s -> (a, s)) -> State s a
state = State
get :: State s s
get = state (\s -> (s, s))
put :: s -> State s ()
put s = state (\_ -> ((), s))
modify :: (s -> s) -> State s ()
modify f = state (\s -> ((), f s))
evalState :: State s a -> s -> a
evalState m s = fst (runState m s)
execState :: State s a -> s -> s
execState m s = snd (runState m s)
......@@ -14,7 +14,8 @@ module FlatCurry.CaseLifting where
import List ( maximum, union )
import FlatCurry.Goodies ( allVars )
import Control.Monad.State
import FlatCurry.Goodies ( allVars, funcName )
import FlatCurry.Types
------------------------------------------------------------------------------
......@@ -22,122 +23,164 @@ import FlatCurry.Types
data LiftOptions = LiftOptions
{ liftCase :: Bool -- lift nested cases?
, liftCArg :: Bool -- lift non-variable case arguments?
, 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 ("","")
defaultLiftOpts = LiftOptions True True
--- Default options for lifting no nested case/let/free expression.
defaultNoLiftOpts :: LiftOptions
defaultNoLiftOpts = LiftOptions False False ("","")
defaultNoLiftOpts = LiftOptions False False
-- Add suffix to case function
addSuffix2Fun :: LiftOptions -> String -> LiftOptions
addSuffix2Fun opts suff =
let (mn,fn) = currFun opts
in opts { currFun = (mn, fn ++ suff) }
------------------------------------------------------------------------------
--- Options for case/let/free lifting.
data LiftState = LiftState
{ liftOpts :: LiftOptions -- lifting options
, currMod :: String -- name of current module
, topFuncs :: [String] -- name of all origin top-level functions
, liftFuncs :: [FuncDecl] -- new functions generated by lifting
, currFunc :: String -- name of current top-level function to be lifted
, currIndex :: Int -- index for generating new function names
}
type LiftingState a = State LiftState a
-- Get lifting options from current state.
getOpts :: LiftingState LiftOptions
getOpts = get >>= return . liftOpts
-- Create a new function name from the current function w.r.t. a suffix.
genFuncName :: String -> LiftingState QName
genFuncName suffix = do
st <- get
let newfn = currFunc st ++ '_' : suffix ++ show (currIndex st)
put st { currIndex = currIndex st + 1 }
if newfn `elem` topFuncs st
then genFuncName suffix
else return (currMod st, newfn)
-- Modify a state by adding a function declaration.
addFun2State :: FuncDecl -> LiftState -> LiftState
addFun2State fd st = st { liftFuncs = fd : liftFuncs st }
------------------------------------------------------------------------------
--- 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 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
in Func fn ar vis texp nrule : nfs
liftRule :: LiftOptions -> Rule -> (Rule, [FuncDecl])
liftRule _ (External n) = (External n, [])
liftRule opts (Rule args rhs) =
let (nrhs, nfs) = liftExp opts False rhs
in (Rule args nrhs, nfs)
let alltopfuns = map (snd . funcName) funs
initstate = LiftState opts mn alltopfuns [] "" 0
transfuns = evalState (mapM liftTopFun funs) initstate
in Prog mn imps types (concat transfuns) ops
-- Lift top-level function.
liftTopFun :: FuncDecl -> LiftingState [FuncDecl]
liftTopFun (Func fn ar vis texp rule) = do
st0 <- get
put st0 { currFunc = snd fn, currIndex = 0 }
nrule <- liftRule rule
st <- get
put st { liftFuncs = [] }
return $ Func fn ar vis texp nrule : liftFuncs st
-- Lift newly introduced function.
liftNewFun :: FuncDecl -> LiftingState FuncDecl
liftNewFun (Func fn ar vis texp rule) = do
nrule <- liftRule rule
return $ Func fn ar vis texp nrule
liftRule :: Rule -> LiftingState Rule
liftRule (External n) = return (External n)
liftRule (Rule args rhs) = do
nrhs <- liftExp False rhs
return (Rule args nrhs)
-- 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 True n e)
(zip [1..] es))
in (Comb ct qn nes, concat nfs)
liftExp opts nested exp@(Case ct e brs) = case e of
Var _ -> liftCaseExp
_ -> if liftCArg opts then liftCaseArg else liftCaseExp
liftExp :: Bool -> Expr -> LiftingState Expr
liftExp _ (Var v) = return (Var v)
liftExp _ (Lit l) = return (Lit l)
liftExp _ (Comb ct qn es) = do
nes <- mapM (liftExp True) es
return (Comb ct qn nes)
liftExp nested exp@(Case ct e brs) = do
opts <- getOpts
case e of
Var _ -> liftCaseExp
_ -> if liftCArg opts then liftCaseArg else liftCaseExp
where
liftCaseExp =
liftCaseExp = do
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 True 0 e
(nbrs, nfs) = unzip (map (liftBranch opts) (zip [1..] brs))
in (Case ct ne nbrs, nefs ++ concat nfs)
then do
cfn <- genFuncName "CASE"
let vs = unboundVars exp
noneType = TCons ("Prelude","None") []
caseFunc = Func cfn (length vs) Private noneType (Rule vs exp)
casefun <- liftNewFun caseFunc
modify (addFun2State casefun)
return $ Comb FuncCall cfn (map Var vs)
else do
ne <- liftExp True e
nbrs <- mapM liftBranch brs
return $ Case ct ne nbrs
liftBranch (Branch pat be) = do
opts <- getOpts
ne <- liftExp (liftCase opts) be
return (Branch pat ne)
-- lift case with complex (non-variable) case argument:
liftCaseArg =
let (ne, nefs) = liftExpArg opts True 0 e
casevar = maximum (0 : allVars exp) + 1
liftCaseArg = do
ne <- liftExp True e
cfn <- genFuncName "COMPLEXCASE"
let casevar = maximum (0 : allVars exp) + 1
vs = unionMap unboundVarsInBranch brs
cfn = currFun (addSuffix2Fun opts "$COMPLEXCASE")
noneType = TCons ("Prelude","None") []
caseFunc = Func cfn (length vs + 1) Private noneType
(Rule (vs ++ [casevar]) (Case ct (Var casevar) brs))
in (Comb FuncCall cfn (map Var vs ++ [ne]), nefs ++ liftFun opts caseFunc)
casefun <- liftNewFun caseFunc
modify (addFun2State casefun)
return $ Comb FuncCall cfn (map Var vs ++ [ne])
liftExp opts nested exp@(Let bs e)
liftExp nested exp@(Let bs e)
| 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)
= do cfn <- genFuncName "LET"
let vs = unboundVars exp
noneType = TCons ("Prelude","None") []
letFunc = Func cfn (length vs) Private noneType (Rule vs exp)
letfun <- liftNewFun letFunc
modify (addFun2State letfun)
return $ Comb FuncCall cfn (map Var vs)
| otherwise
= let (nes,nfs1) = unzip (map (\ (n,be) -> liftExpArg opts True n be)
(zip [1..] (map snd bs)))
(ne,nfs2) = liftExpArg opts True 0 e
in (Let (zip (map fst bs) nes) ne, concat nfs1 ++ nfs2)
= do nes <- mapM (liftExp True) (map snd bs)
ne <- liftExp True e
return $ Let (zip (map fst bs) nes) ne
liftExp opts nested exp@(Free vs e)
liftExp nested exp@(Free vs e)
| nested -- lift nested free declarations by creating new function
= let fvs = unboundVars exp
cfn = currFun (addSuffix2Fun opts "$FREE")
noneType = TCons ("Prelude","None") []
freeFunc = Func cfn (length fvs) Private noneType (Rule fvs exp)
in (Comb FuncCall cfn (map Var fvs), liftFun opts freeFunc)
= do cfn <- genFuncName "FREE"
let fvs = unboundVars exp
noneType = TCons ("Prelude","None") []
freeFunc = Func cfn (length fvs) Private noneType (Rule fvs exp)
freefun <- liftNewFun freeFunc
modify (addFun2State freefun)
return $ Comb FuncCall cfn (map Var fvs)
| otherwise
= let (ne, nfs) = liftExp opts True e
in (Free vs ne, nfs)
liftExp opts _ (Or e1 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
in (Typed ne te, nfs)
-- 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 -> 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 (liftCase opts) bnum e
in (Branch pat ne, nfs)
= do ne <- liftExp True e
return (Free vs ne)
liftExp _ (Or e1 e2) = do
ne1 <- liftExp True e1
ne2 <- liftExp True e2
return (Or ne1 ne2)
liftExp nested (Typed e te) = do
ne <- liftExp nested e
return (Typed ne te)
--- Find all variables which are not bound in an expression.
unboundVars :: Expr -> [VarIndex]
......
......@@ -170,9 +170,9 @@ trRule opts (Rule args rhs) = IFuncBody (toIBlock opts args rhs 0)
toIBlock :: ICOptions -> [VarIndex] -> Expr -> Int -> IBlock
toIBlock opts vs e root =
IBlock (map IVarDecl vs ++ varDecls)
(map (\ (p,i) -> IVarAssign i (IVarAccess root [p])) (zip [0..] vs) ++
varAssigns)
IBlock (map IVarDecl (filter (`elem` evars) vs) ++ varDecls)
(map (\ (p,i) -> IVarAssign i (IVarAccess root [p]))
(filter ((`elem` evars) . snd) (zip [0..] vs)) ++ varAssigns)
(case e of
Case _ ce brs@(Branch (Pattern _ _) _ : _) ->
let carg = trCaseArg ce
......@@ -183,6 +183,8 @@ toIBlock opts vs e root =
Comb FuncCall fn [] | fn == pre "failed" -> IExempt
_ -> IReturn (toIExpr opts e))
where
evars = allVars e
varDecls = case e of
Free fvs _ -> map IFreeDecl fvs
Let bs _ -> map (IVarDecl .fst) bs
......@@ -191,7 +193,7 @@ toIBlock opts vs e root =
_ -> []
-- fresh variable to translate complex case arguments:
caseVar = maximum (0 : allVars e) + 1
caseVar = maximum (0 : evars) + 1
varAssigns = case e of
Let bs _ ->
......
......@@ -2,7 +2,7 @@
--- This module contains a simple compiler from FlatCurry to ICurry programs.
---
--- @author Michael Hanus
--- @version February 2020
--- @version May 2020
------------------------------------------------------------------------------
module ICurry.Main where
......@@ -30,7 +30,7 @@ testI p =
banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "ICurry Compiler (Version of 19/02/20)"
bannerText = "ICurry Compiler (Version of 12/05/20)"
bannerLine = take (length bannerText) (repeat '=')
main :: IO ()
......
......@@ -7,7 +7,7 @@
module ICurry.Pretty where
import List ( intersperse )
import List ( intercalate, intersperse )
import ICurry.Types
import Text.Pretty
......@@ -76,7 +76,12 @@ ppFunctions = vsepBlank . map ppFunction
--- @param fns the function
--- @return the pretty printed function
ppFunction :: IFunction -> Doc
ppFunction (IFunction name _ _ _ body) = ppQName name <+> ppFuncBody body
ppFunction (IFunction name ar _ demargs body) =
ppQName name <> char '/' <> int ar <>
(if null demargs
then empty
else text (" (DEMANDED: " ++ intercalate "," (map show demargs) ++ ")"))
<+> char ':' <+> ppFuncBody body
--- Pretty print a qualified ICurry name (module.localname)
--- @param name the name
......@@ -88,8 +93,8 @@ ppQName (modname, localname, _) = text $ modname ++ '.' : localname
--- @param body the function's body
--- @return the pretty printed function body
ppFuncBody :: IFuncBody -> Doc
ppFuncBody (IExternal name) = text ("external \"" ++ name ++ "\",")
ppFuncBody (IFuncBody block) = equals <+> ppBlock block
ppFuncBody (IExternal name) = text ("external \"" ++ name ++ "\",")
ppFuncBody (IFuncBody block) = ppBlock block
--- Pretty print a list of variables
--- @param vs the variables
......
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