mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
c7b016c07d
This changes lots of stuff, let me know if it broke anything. Comments: - We use a local hacked version of GetOpt that allows long forms of commands to start with a single dash. This breaks other parts of GetOpt. For example, arguments to short options now require a =, and does not allo pace after the option character. - The new command parsing is currently only used for the program command line, pragmas and the arguments for the 'i' shell command. - I made a quick hack for the options for showTerm, which currently makes it impossible to use the print style flags for cc. This will be replaced by a facility for parsing command-specific options. - The verbosity handling is broken in some places. I will fix that in a later patch.
103 lines
3.1 KiB
Haskell
103 lines
3.1 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : BackOpt
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/04/21 16:21:33 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.6 $
|
|
--
|
|
-- Optimizations on GF source code: sharing, parametrization, value sets.
|
|
--
|
|
-- optimization: sharing branches in tables. AR 25\/4\/2003.
|
|
-- following advice of Josef Svenningsson
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Compile.BackOpt (shareModule, OptSpec) where
|
|
|
|
import GF.Grammar.Grammar
|
|
import GF.Infra.Ident
|
|
import GF.Infra.Option
|
|
import qualified GF.Grammar.Macros as C
|
|
import GF.Grammar.PrGrammar (prt)
|
|
import GF.Data.Operations
|
|
import Data.List
|
|
import qualified GF.Infra.Modules as M
|
|
import qualified Data.ByteString.Char8 as BS
|
|
|
|
type OptSpec = [Optimization]
|
|
|
|
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
|
|
shareModule opt (i,m) = case m of
|
|
M.ModMod (M.Module mt st fs me ops js) ->
|
|
(i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
|
|
_ -> (i,m)
|
|
|
|
shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
|
|
shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
|
|
shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
|
|
shareInfo _ i = i
|
|
|
|
-- the function putting together optimizations
|
|
shareOptim :: OptSpec -> Ident -> Term -> Term
|
|
shareOptim opt c = (if OptValues `elem` opt then values else id)
|
|
. (if OptParametrize `elem` opt then factor c 0 else id)
|
|
|
|
-- do even more: factor parametric branches
|
|
|
|
factor :: Ident -> Int -> Term -> Term
|
|
factor c i t = case t of
|
|
T _ [_] -> t
|
|
T _ [] -> t
|
|
T (TComp ty) cs ->
|
|
T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
|
|
_ -> C.composSafeOp (factor c i) t
|
|
where
|
|
|
|
factors i psvs = -- we know psvs has at least 2 elements
|
|
let p = qqIdent c i
|
|
vs' = map (mkFun p) psvs
|
|
in if allEqs vs'
|
|
then mkCase p vs'
|
|
else psvs
|
|
|
|
mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
|
|
|
|
allEqs (v:vs) = all (==v) vs
|
|
|
|
mkCase p (v:_) = [(PV p, v)]
|
|
|
|
--- we hope this will be fresh and don't check... in GFC would be safe
|
|
|
|
qqIdent c i = identC (BS.pack ("q_" ++ prt c ++ "__" ++ show i))
|
|
|
|
|
|
-- we need to replace subterms
|
|
|
|
replace :: Term -> Term -> Term -> Term
|
|
replace old new trm = case trm of
|
|
|
|
-- these are the important cases, since they can correspond to patterns
|
|
QC _ _ | trm == old -> new
|
|
App t ts | trm == old -> new
|
|
App t ts -> App (repl t) (repl ts)
|
|
R _ | isRec && trm == old -> new
|
|
_ -> C.composSafeOp repl trm
|
|
where
|
|
repl = replace old new
|
|
isRec = case trm of
|
|
R _ -> True
|
|
_ -> False
|
|
|
|
-- It is very important that this is performed only after case
|
|
-- expansion since otherwise the order and number of values can
|
|
-- be incorrect. Guaranteed by the TComp flag.
|
|
|
|
values :: Term -> Term
|
|
values t = case t of
|
|
T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
|
|
T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
|
|
_ -> C.composSafeOp values t
|