|
sourcecode:
|
module ICurry.Compiler
( icCompile, flatCurry2ICurry, flatCurry2ICurryWithProgs
, flatCurry2ICurryWithProgsAndOptions
, ICOptions(..), defaultICOptions
, printStatus, printIntermediate ) where
import Control.Monad ( when )
import Data.List ( elemIndex, find, maximum )
import FlatCurry.ElimNewtype ( elimNewtype )
import FlatCurry.Files ( readFlatCurryWithParseOptions
, readFlatCurryIntWithParseOptions )
import FlatCurry.Goodies ( allVars, consName, funcName, funcVisibility
, progFuncs, progImports, progName, progTypes )
import FlatCurry.Pretty ( defaultOptions, ppProg )
import FlatCurry.Types
import Text.Pretty ( pPrint )
import FlatCurry.CaseCompletion
import FlatCurry.CaseLifting ( defaultLiftOpts, defaultNoLiftOpts, liftProg )
import ICurry.Files ( iCurryFileName, writeICurryFile )
import ICurry.Options
import ICurry.Pretty ( ppIProg )
import ICurry.Types
test :: String -> IO ()
test p = do
iprog <- icCompile defaultICOptions { optVerb = 3 } p
writeICurryFile (iCurryFileName p) iprog
putStrLn $ "ICurry program written to '" ++ iCurryFileName p ++ "'"
------------------------------------------------------------------------------
--- Generates an ICurry program by reading a FlatCurry program and
--- compiling it to ICurry.
icCompile :: ICOptions -> String -> IO IProg
icCompile opts p = do
printStatus opts $ "Reading FlatCurry program '" ++ p ++ "'..."
prog <- readFlatCurryWithParseOptions p (optFrontendParams opts)
flatCurry2ICurry opts prog
--- Translates a FlatCurry program into an ICurry program.
--- It also reads the imported modules in order to access their
--- data and function declarations.
flatCurry2ICurry :: ICOptions -> Prog -> IO IProg
flatCurry2ICurry opts prog0 = flatCurry2ICurryWithProgs opts [] prog0
--- Translates a FlatCurry program into an ICurry program where
--- some FlatCurry interfaces are provided.
--- It also reads the interfaces of imported modules, if not already
--- provided, in order to access their data and function declarations.
flatCurry2ICurryWithProgs :: ICOptions -> [Prog] -> Prog -> IO IProg
flatCurry2ICurryWithProgs opts impprogs prog =
flatCurry2ICurryWithProgsAndOptions opts impprogs prog >>= return . snd
--- Translates a FlatCurry program into an ICurry program where
--- some FlatCurry interfaces are provided.
--- It also reads the interfaces of imported modules, if not already
--- provided, in order to access their data and function declarations.
--- The `ICOptions` after processing the program (containing the
--- constructor and function maps required for the translation)
--- are also returned.
flatCurry2ICurryWithProgsAndOptions :: ICOptions -> [Prog] -> Prog
-> IO (ICOptions,IProg)
flatCurry2ICurryWithProgsAndOptions opts progs prog0 = do
let impmods = progImports prog0
impprogs <- mapM getInterface impmods
let prog = elimNewtype impprogs prog0
datadecls = concatMap dataDeclsOf (prog : impprogs)
ccprog = completeProg (CaseOptions datadecls) prog
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)
let consmap = map consMapOfProg (prog : impprogs)
impfunmap = map publicFunMapOfProg impprogs
pubfunmap = snd (publicFunMapOfProg prog)
funmap = (progName prog,
pubfunmap ++ privateFunMapOfProg clprog pubfunmap) :
impfunmap
let cmpopts = setConsFuns opts consmap funmap
icprog = flat2icurry cmpopts clprog
printIntermediate opts $
textWithLines "Generated ICurry program:" ++
pPrint (ppIProg icprog)
printDetails opts (textWithLines "Generated ICurry file:" ++ showIProg icprog)
return (cmpopts,icprog)
where
getInterface p =
maybe (do printStatus opts $ "Read FlatCurry interface of '" ++ p ++ "'"
readFlatCurryIntWithParseOptions p (optFrontendParams opts))
return
(find (\fp -> progName fp == p) progs)
consMapOfProg fcy =
(progName fcy,
concatMap (\ (_,cars) -> map (\ ((cname,car),pos) -> (cname,(car,pos)))
(zip cars [0..]))
(dataDeclsOf fcy))
-- compute mapping of public function names to indices
publicFunMapOfProg fcprog =
(progName fcprog,
zip (map funcName
(filter (\f -> funcVisibility f == FlatCurry.Types.Public)
(progFuncs fcprog)))
[0..])
privateFunMapOfProg fcprog pubfunmap =
zip (filter (\fn -> fn `notElem` map fst pubfunmap)
(map funcName (progFuncs fcprog)))
[(length pubfunmap) ..]
textWithLines s = unlines [l, s, l]
where l = take 78 (repeat '-')
------------------------------------------------------------------------------
--- Translation from FlatCurry to ICurry according to the transformation
--- specified in the ICurry paper.
flat2icurry :: ICOptions -> Prog -> IProg
flat2icurry opts (Prog modname imps types funs _) =
IProg modname imps
(concatMap trTypeDecl (zip [0..] types))
(map (trFunc opts) funs)
where
trTypeDecl (_, TypeSyn _ _ _ _) = []
trTypeDecl (_, TypeNew _ _ _ _) =
error $ "ICurry.Compiler: newtype occurred!" -- should not occur...
trTypeDecl (ti, Type (mn,tn) _ _ cdecl) =
[IDataType (mn,tn,ti)
(map (\ (i, Cons (cmn,cn) ar _ _) -> ((cmn,cn,i),ar))
(zip [0..] cdecl))]
trVis :: Visibility -> IVisibility
trVis FlatCurry.Types.Public = ICurry.Types.Public
trVis FlatCurry.Types.Private = ICurry.Types.Private
trFunc :: ICOptions -> FuncDecl -> IFunction
trFunc opts (Func qn@(mn,fn) ar vis _ rule) =
IFunction (mn, fn, posOfFun opts qn) ar (trVis vis) (demandOf rule)
(trRule optsf rule)
where
optsf = opts { optFun = qn }
-- Computes (approximates) the arguments demanded by a rule.
demandOf :: Rule -> [Int]
demandOf (External _) = [] -- TODO
demandOf (Rule args rhs) = case rhs of
Case _ (Var v) _ -> maybe [] (: []) (elemIndex v args)
_ -> []
trRule :: ICOptions -> Rule -> IFuncBody
trRule _ (External s) = IExternal s
trRule opts (Rule args rhs) = IFuncBody (toIBlock opts args rhs 0)
toIBlock :: ICOptions -> [VarIndex] -> Expr -> Int -> IBlock
toIBlock opts vs e root =
IBlock (if optVarDecls opts
then varDecls
else map IVarDecl (filter (`elem` evars) vs) ++ varDecls)
(map (\ (p,i) -> IVarAssign i (IVarAccess root [p]))
(filter ((`elem` evars) . snd) (zip [0..] vs)) ++
fst varAssigns ++ map fst (snd varAssigns))
(case e of
Case _ ce brs@(Branch (Pattern _ _) _ : _) ->
let carg = trCaseArg ce
in ICaseCons carg (map (trPBranch carg) brs)
Case _ ce brs@(Branch (LPattern _ ) _ : _) ->
let carg = trCaseArg ce
in ICaseLit carg (map (trLBranch carg) brs)
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 _ -> if optVarDecls opts
then map IVarDecl
(filter (`elem` cyclicVars) (map fst bs))
else map (IVarDecl . fst) bs
Case _ (Var _) _ -> []
Case _ _ _ -> if optVarDecls opts then [] else [IVarDecl caseVar]
_ -> []
-- fresh variable to translate complex case arguments:
caseVar = maximum (0 : evars) + 1
-- the assignments for this block: a pair of direct assignments
-- and subsequent assignments required for recursive lets
-- (where the cyclic variables is returned)
varAssigns = case e of
Let bs _ ->
let assigns = map (\ (v,b) -> (v, toIExpr opts b)) bs
in (map (\ (v,be) -> IVarAssign v be) assigns,
-- add assignments of recursive occurrences:
recursiveAssigns assigns)
Case _ (Var _) _ -> ([], [])
Case _ ce _ -> ([IVarAssign caseVar (toIExpr opts ce)], [])
_ -> ([], [])
where
recursiveAssigns [] = []
recursiveAssigns (ve:ves) =
let vps = varPos [] (snd ve)
in map (\ (v,p) -> (INodeAssign (fst ve) p (IVar v), v))
(filter (\vp -> fst vp `elem` map fst (ve:ves)) vps) ++
recursiveAssigns ves
-- variables used to implement cyclic data structures
cyclicVars = map snd (snd varAssigns)
trCaseArg ce = case ce of
Var v -> v
_ -> caseVar
trPBranch carg (Branch (Pattern qn@(mn,cn) pvs) be) =
let (ar,pos) = arityPosOfCons opts qn
in IConsBranch (mn, cn, pos) ar (toIBlock opts pvs be carg)
trPBranch _ (Branch (LPattern _) _) = funError opts "trPBranch with LPattern"
trLBranch carg (Branch (LPattern lit) be) =
ILitBranch (trLit lit) (toIBlock opts [] be carg)
trLBranch _ (Branch (Pattern _ _) _) = funError opts "trLBranch with Pattern"
toIExpr :: ICOptions -> Expr -> IExpr
toIExpr _ (Var v) = IVar v
toIExpr _ (Lit l) = ILit (trLit l)
toIExpr opts (Comb ct qn@(mn,fn) es)
| qn == pre "?" && length es == 2
= toIExpr opts (Or (es!!0) (es!!1))
| otherwise
= let icall = case ct of
FuncCall -> IFCall (mn, fn, posOfFun opts qn)
ConsCall -> ICCall (mn, fn, posOfCons opts qn)
FuncPartCall m -> IFPCall (mn, fn, posOfFun opts qn) m
ConsPartCall m -> ICPCall (mn, fn, posOfCons opts qn) m
in icall (map (toIExpr opts) es)
toIExpr opts (Or e1 e2) = IOr (toIExpr opts e1) (toIExpr opts e2)
toIExpr opts (Typed e _) = toIExpr opts e
toIExpr opts (Let _ e) = toIExpr opts e
toIExpr opts (Free _ e) = toIExpr opts e
toIExpr opts (Case _ _ _) = funError opts "toIExpr: Case occurred"
trLit :: Literal -> ILiteral
trLit (Intc i) = IInt i
trLit (Floatc f) = IFloat f
trLit (Charc c) = IChar c
-- Extracts the variables and their positions occurring in an ICurry expression
varPos :: [Int] -> IExpr -> [(IVarIndex,[Int])]
varPos rpos (IVar v) = [(v,rpos)]
varPos _ (IVarAccess _ _) = []
varPos _ (ILit _) = []
varPos rpos (IFCall _ args) = concatMap (\ (i,e) -> varPos (rpos ++ [i]) e)
(zip [0..] args)
varPos rpos (ICCall qn args) = varPos rpos (IFCall qn args)
varPos rpos (IFPCall qn _ args) = varPos rpos (IFCall qn args)
varPos rpos (ICPCall qn _ args) = varPos rpos (IFCall qn args)
varPos rpos (IOr e1 e2) = varPos (rpos ++ [0]) e1 ++ varPos (rpos ++ [1]) e2
------------------------------------------------------------------------------
--- Simple show for ICurry programs.
showIProg :: IProg -> String
showIProg (IProg mn imps types funs) = unlines $
unwords ["IProg", mn, show imps, show types] :
"[" : map show funs ++ ["]"]
------------------------------------------------------------------------------
-- Auxiliaries:
pre :: String -> QName
pre s = ("Prelude", s)
------------------------------------------------------------------------------
|