Commit 104a1965 authored by Michael Hanus 's avatar Michael Hanus

Option --nolifting added

parent 4334e6a0
......@@ -20,11 +20,20 @@ import FlatCurry.Types
------------------------------------------------------------------------------
--- Options for case/let/free lifting.
data LiftOptions = LiftOptions
{ currFun :: QName -- name of current function to be lifted
{ 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)
}
defaultOpts :: LiftOptions
defaultOpts = LiftOptions ("","")
--- Default options for lifting all nested case/let/free expressions.
defaultLiftOpts :: LiftOptions
defaultLiftOpts = LiftOptions True True True True ("","")
--- Default options for lifting no nested case/let/free expression.
defaultNoLiftOpts :: LiftOptions
defaultNoLiftOpts = LiftOptions False False False False ("","")
-- Add suffix to case function
addSuffix2Fun :: LiftOptions -> String -> LiftOptions
......@@ -59,21 +68,20 @@ liftExp opts _ (Comb ct qn es) =
let (nes,nfs) = unzip (map (\ (n,e) -> liftExpArg opts n e) (zip [1..] es))
in (Comb ct qn nes, concat nfs)
liftExp opts lft exp@(Case ct e brs) = case e of
Var _ -> liftCaseExp lft
_ -> liftCaseArg
liftExp opts nested exp@(Case ct e brs) = case e of
Var _ -> liftCaseExp
_ -> if liftCArg opts then liftCaseArg else liftCaseExp
where
liftCaseExp False =
let (ne, nefs) = liftExpArg opts 0 e
(nbrs, nfs) = unzip (map (liftBranch opts) (zip [1..] brs))
in (Case ct ne nbrs, nefs ++ concat nfs)
-- lift case expression by creating new function call:
liftCaseExp True =
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)
liftCaseExp =
if nested && liftCase opts -- 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
(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 =
......@@ -86,35 +94,36 @@ liftExp opts lft exp@(Case ct e brs) = case e of
(Rule (vs ++ [casevar]) (Case ct (Var casevar) brs))
in (Comb FuncCall cfn (map Var vs ++ [ne]), nefs ++ liftFun opts caseFunc)
liftExp opts False (Let bs e) =
let (nes,nfs1) = unzip (map (\ (n,be) -> liftExpArg opts n be)
(zip [1..] (map snd bs)))
(ne,nfs2) = liftExpArg opts 0 e
in (Let (zip (map fst bs) nes) ne, concat nfs1 ++ nfs2)
-- lift let expression by creating new function call:
liftExp opts True exp@(Let _ _) =
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)
liftExp opts False (Free vs e) =
let (ne, nfs) = liftExp opts True e
in (Free vs ne, nfs)
liftExp opts True exp@(Free _ _) =
let vs = unboundVars exp
cfn = currFun (addSuffix2Fun opts "$FREE")
noneType = TCons ("Prelude","None") []
freeFunc = Func cfn (length vs) Private noneType (Rule vs exp)
in (Comb FuncCall cfn (map Var vs), liftFun opts freeFunc)
liftExp opts nested exp@(Let bs e)
| nested && liftLet opts -- lift let expression 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)
(zip [1..] (map snd bs)))
(ne,nfs2) = liftExpArg opts 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
= 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)
| otherwise
= let (ne, nfs) = liftExp opts True e
in (Free vs ne, nfs)
liftExp opts _ (Or e1 e2) =
let (ne1, nfs1) = liftExpArg opts 1 e1
(ne2, nfs2) = liftExpArg opts 2 e2
in (Or ne1 ne2, nfs1 ++ nfs2)
liftExp opts lft (Typed e te) =
let (ne, nfs) = liftExp opts lft e
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
......
......@@ -13,18 +13,18 @@ module ICurry.Compiler where
import List ( elemIndex, maximum )
import FlatCurry.Files
import FlatCurry.Files ( readFlatCurry )
import FlatCurry.Goodies ( allVars, consName, funcName, funcVisibility
, progFuncs, progImports, progTypes )
import FlatCurry.Pretty
import FlatCurry.Pretty ( defaultOptions, ppProg )
import FlatCurry.Types
import Text.Pretty
import Text.Pretty ( pPrint )
import FlatCurry.CaseCompletion
import FlatCurry.CaseLifting
import FlatCurry.CaseLifting ( defaultLiftOpts, defaultNoLiftOpts, liftProg )
import ICurry.Files
import ICurry.Pretty
import ICurry.Files ( iCurryFileName, writeICurryFile )
import ICurry.Pretty ( ppIProg )
import ICurry.Types
test :: String -> IO ()
......@@ -45,7 +45,9 @@ icCompile opts p = do
impprogs <- mapM readFlatCurry impmods
let datadecls = concatMap dataDeclsOf (prog : impprogs)
ccprog = completeProg (CaseOptions datadecls) prog
clprog = liftProg defaultOpts ccprog
clprog = if optLift opts
then liftProg defaultLiftOpts ccprog
else liftProg defaultNoLiftOpts ccprog
printDetails opts $
textWithLines "Transformed FlatCurry program to be compiled:" ++
pPrint (ppProg FlatCurry.Pretty.defaultOptions clprog)
......@@ -87,19 +89,22 @@ icCompile opts p = do
--- Contains mappings from constructor and functions names
--- into locally unique integers and other stuff.
data ICOptions = ICOptions
{ optVerb :: Int -- verbosity (0: quiet, 1: status, 2: interm, 3: all)
, optHelp :: Bool -- if help info should be printed
, optMain :: String -- name of main function
, optShowGraph :: Bool -- visualize graph during execution?
, optViewPDF :: String -- command to view graph PDF
{ optVerb :: Int -- verbosity
-- (0: quiet, 1: status, 2: intermediate, 3: all)
, optHelp :: Bool -- if help info should be printed
, optLift :: Bool -- should nested cases/lets be lifted to top-level?
, optMain :: String -- name of main function
, optShowGraph :: Bool -- visualize graph during execution?
, optViewPDF :: String -- command to view graph PDF
, optInteractive :: Bool -- interactive execution?
-- internal options
, optConsMap :: [(QName,(IArity,Int))] -- map: cons. names to arity/position
, optFunMap :: [(QName,Int)] -- map: function names to module indices
, optFun :: QName -- currently compiled function
}
defaultICOptions :: ICOptions
defaultICOptions = ICOptions 1 False "" False "evince" False [] [] ("","")
defaultICOptions = ICOptions 1 False True "" False "evince" False [] [] ("","")
-- Lookup arity and position index of a constructor.
arityPosOfCons :: ICOptions -> QName -> (IArity,Int)
......
......@@ -18,11 +18,19 @@ import ICurry.Files
import ICurry.Interpreter
import ICurry.Types
test :: String -> IO ()
test p = mainProg defaultICOptions { optVerb = 3, optMain = "main" } p
testI :: String -> IO ()
testI p =
mainProg defaultICOptions { optVerb = 3, optMain = "main"
, optShowGraph = True, optInteractive = True } p
------------------------------------------------------------------------------
banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "ICurry Compiler (Version of 03/02/20)"
bannerText = "ICurry Compiler (Version of 09/02/20)"
bannerLine = take (length bannerText) (repeat '=')
main :: IO ()
......@@ -65,14 +73,15 @@ processOptions argv = do
unless (null opterrors)
(putStr (unlines opterrors) >> printUsage >> exitWith 1)
when (optHelp opts) (printUsage >> exitWith 0)
when (not (null (optMain opts)) && not (optLift opts)) $ error
"Incompatible options: nested case/let must be lifted for the interpreter"
return (opts, map stripCurrySuffix args)
where
printUsage = putStrLn (banner ++ "\n" ++ usageText)
-- Help text
usageText :: String
usageText =
usageInfo ("Usage: icurry [options] <module name>\n") options
usageText = usageInfo ("Usage: icurry [options] <module name>\n") options
-- Definition of actual command line options.
options :: [OptDescr (ICOptions -> ICOptions)]
......@@ -98,6 +107,9 @@ options =
, Option "i" ["interactive"]
(NoArg (\opts -> opts { optInteractive = True }))
"interactive execution (ask after each result or step)"
, Option "" ["nolifting"]
(NoArg (\opts -> opts { optLift = False }))
"do not lift nested case/let expressions"
]
where
safeReadNat opttrans s opts =
......
......@@ -42,7 +42,7 @@ data IDataType = IDataType IQName [(IQName,IArity)]
deriving (Show, Read)
--- An ICurry function declaration consisting of the function's name, arity,
--- the positions of demandeded arguments (0 = first argument),
--- the positions of always demandeded arguments (0 = first argument),
--- and a body.
data IFunction = IFunction IQName IArity IVisibility [Int] IFuncBody
deriving (Show, Read)
......
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