GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Preliminary new shell feature: cc -trace.

Browse Source 
You can now do things like 

	cc -trace mkV "debug"

to see a trace of all opers with their arguments and results during the
computation of mkV "debug".
This commit is contained in:
hallgren
2015-09-28 22:23:56 +00:00
parent 82f238fe2b
commit 35be182824
8 changed files with 89 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
src/compiler/GF/Command/SourceCommands.hs
View File

@@ -7,7 +7,7 @@ import qualified Data.ByteString.UTF8 as UTF8(fromString)
import qualified Data.Map as Map
import GF.Infra.SIO(MonadSIO(..),restricted)
import GF.Infra.Option(noOptions)
import GF.Infra.Option(modifyFlags,optTrace) --,noOptions
import GF.Data.Operations (chunks,err,raise)
import GF.Text.Pretty(render)
@@ -49,7 +49,8 @@ sourceCommands = Map.fromList [
("list","all strings, comma-separated on one line"),
("one","pick the first strings, if there is any, from records and tables"),
("table","show all strings labelled by parameters"),
("unqual","hide qualifying module names")
("unqual","hide qualifying module names"),
("trace","trace computations")
],
needsTypeCheck = False, -- why not True?
exec = withStrings compute_concrete
@@ -165,7 +166,7 @@ sourceCommands = Map.fromList [
Left (_,msg) -> return $ pipeMessage msg
Right t -> return $ err pipeMessage
(fromString . showTerm sgr style q)
$ checkComputeTerm sgr t
$ checkComputeTerm opts sgr t
where
(style,q) = pOpts TermPrintDefault Qualified opts
s = unwords ws
@@ -207,7 +208,7 @@ sourceCommands = Map.fromList [
ops <- case ts of
_:_ -> do
let Right t = runP pExp (UTF8.fromString (unwords ts))
ty <- err error return $ checkComputeTerm sgr t
ty <- err error return $ checkComputeTerm os sgr t
return $ allOpersTo sgr ty
_ -> return $ allOpers sgr
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
@@ -251,9 +252,11 @@ sourceCommands = Map.fromList [
P.putStrLn "wrote graph in file _gfdepgraph.dot"
return void
checkComputeTerm sgr t = do
mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
t1 <- return (CN.normalForm (CN.resourceValues noOptions sgr) (L NoLoc identW) t)
checkPredefError t1
checkComputeTerm os sgr t =
do mo <- maybe (raise "no source grammar in scope") return $
greatestResource sgr
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t
checkPredefError t1

67
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -7,7 +7,7 @@ module GF.Compile.Compute.ConcreteNew
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace)
import GF.Grammar.PatternMatch(matchPattern,measurePatt)
import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
import GF.Compile.Compute.Value hiding (Error)
@@ -21,7 +21,7 @@ import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
--import Data.Char (isUpper,toUpper,toLower)
import GF.Text.Pretty
import qualified Data.Map as Map
--import Debug.Trace(trace)
import Debug.Trace(trace)
-- * Main entry points
@@ -41,10 +41,11 @@ eval ge t = ($[]) # value (toplevel ge) t
type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
data GlobalEnv = GE Grammar ResourceValues Options (L Ident)
data GlobalEnv = GE Grammar ResourceValues Options GLocation
data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
opts::Options,
gloc::L Ident,local::LocalScope}
gloc::GLocation,local::LocalScope}
type GLocation = L Ident
type LocalScope = [Ident]
type Stack = [Value]
type OpenValue = Stack->Value
@@ -85,7 +86,24 @@ resourceValues opts gr = env
rvs = Map.mapWithKey moduleResources (moduleMap gr)
moduleResources m = Map.mapWithKey (moduleResource m) . jments
moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
eval (GE gr rvs opts (L l c)) t
let loc = L l c
qloc = L l (Q (m,c))
eval (GE gr rvs opts loc) (traceRes qloc t)
traceRes = if flag optTrace opts
then traceResource
else const id
-- * Tracing
-- | Insert a call to the trace function under the top-level lambdas
traceResource (L l q) t =
case termFormCnc t of
(abs,body) -> mkAbs abs (mkApp traceQ [args,body])
where
args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
lstr = render (l<>":"<>ppTerm Qualified 0 q)
traceQ = Q (cPredef,cTrace)
-- * Computing values
@@ -390,35 +408,38 @@ apply' env t vs =
in \ svs -> maybe constr id (Map.lookup f predefs)
$ map ($svs) vs
| otherwise -> do r <- resource env x
return $ \ svs -> vapply r (map ($svs) vs)
return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
-}
App t1 t2 -> apply' env t1 . (:vs) =<< value env t2
_ -> do fv <- value env t
return $ \ svs -> vapply (fv svs) (map ($svs) vs)
return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
vapply :: Value -> [Value] -> Value
vapply v [] = v
vapply v vs =
vapply :: GLocation -> Value -> [Value] -> Value
vapply loc v [] = v
vapply loc v vs =
case v of
VError {} -> v
-- VClosure env (Abs b x t) -> beta gr env b x t vs
VAbs bt _ (Bind f) -> vbeta bt f vs
VApp pre vs1 -> err msg vfv $ mapM (delta pre) (varyList (vs1++vs))
VAbs bt _ (Bind f) -> vbeta loc bt f vs
VApp pre vs1 -> delta' pre (vs1++vs)
where
delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
in vtrace loc v1 vr
delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
--msg = const (VApp pre (vs1++vs))
msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
VS (VV t pvs fs) s -> VS (VV t pvs [vapply f vs|f<-fs]) s
VFV fs -> vfv [vapply f vs|f<-fs]
VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
VFV fs -> vfv [vapply loc f vs|f<-fs]
VCApp f vs0 -> VCApp f (vs0++vs)
v -> bug $ "vapply "++show v++" "++show vs
vbeta bt f (v:vs) =
vbeta loc bt f (v:vs) =
case (bt,v) of
(Implicit,VImplArg v) -> ap v
(Explicit, v) -> ap v
where
ap (VFV avs) = vfv [vapply (f v) vs|v<-avs]
ap v = vapply (f v) vs
ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
ap v = vapply loc (f v) vs
vary (VFV vs) = vs
vary v = [v]
@@ -431,10 +452,20 @@ beta env b x t (v:vs) =
(Explicit, v) -> apply' (ext (x,v) env) t vs
-}
vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
where
pv v = case v of
VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
_ -> ppV v
pf (_,VString n) = pp n
pf (_,v) = ppV v
pa (_,v) = ppV v
ppV v = ppT 10 (value2term loc [] v)
-- tr s f vs = trace (s++" "++show vs++" = "++show r) r where r = f vs
-- | Convert a value back to a term
value2term :: L Ident -> [Ident] -> Value -> Term
value2term :: GLocation -> [Ident] -> Value -> Term
value2term loc xs v0 =
case v0 of
VApp pre vs -> foldl App (Q (cPredef,predefName pre)) (map v2t vs)

6
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -75,7 +75,7 @@ predefList =
(cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
(cLessInt,LessInt),
-- cShow, cRead, cMapStr, cEqVal
(cError,Error),
(cError,Error),(cTrace,Trace),
-- Canonical values:
(cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int),
(cInts,Ints),(cNonExist,NonExist)
@@ -101,6 +101,7 @@ delta f vs =
LessInt -> ap2 ((<)::Int->Int->Bool)
{- -- | Show | Read | ToStr | MapStr | EqVal -}
Error -> ap1 VError
Trace -> ap2 vtrace
-- Canonical values:
PBool -> canonical
Int -> canonical
@@ -129,6 +130,9 @@ delta f vs =
| null [v | v@(VApp NonExist _) <- vs] = b
| otherwise = return (toValue a)
vtrace :: Value -> Value -> Value
vtrace x y = y -- tracing is implemented elsewhere
-- unimpl id = bug $ "unimplemented predefined function: "++showIdent id
-- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs

2
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -49,7 +49,7 @@ type Env = [(Ident,Value)]
data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
| ToLower | IsUpper | Length | Plus | EqInt | LessInt
{- | Show | Read | ToStr | MapStr | EqVal -}
| Error
| Error | Trace
-- Canonical values below:
| PBool | PFalse | PTrue | Int | Ints | NonExist
| BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -291,7 +291,7 @@ greatestResource :: Grammar -> Maybe ModuleName
greatestResource gr =
case allResources gr of
[] -> Nothing
a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
mo:_ -> Just mo ---- why not last as in Abstract? works though AR 24/5/2008
-- | all concretes for a given abstract
allConcretes :: Grammar -> ModuleName -> [ModuleName]
@@ -455,7 +455,7 @@ type Equation = ([Patt],Term)
type Labelling = (Label, Type)
type Assign = (Label, (Maybe Type, Term))
type Case = (Patt, Term)
type Cases = ([Patt], Term)
--type Cases = ([Patt], Term)
type LocalDef = (Ident, (Maybe Type, Term))
type Param = (Ident, Context)

1
src/compiler/GF/Grammar/Predef.hs
View File

@@ -61,6 +61,7 @@ cRead = identS "read"
cToStr = identS "toStr"
cMapStr = identS "mapStr"
cError = identS "error"
cTrace = identS "trace"
-- * Hacks: dummy identifiers used in various places.
-- Not very nice!

16
src/compiler/GF/Infra/Location.hs
View File

@@ -25,10 +25,16 @@ noLoc = L NoLoc
ppLocation :: FilePath -> Location -> Doc
ppLocation fpath NoLoc = pp fpath
ppLocation fpath (External p l) = ppLocation p l
ppLocation fpath (Local b e)
| b == e = fpath <> ":" <> b
| otherwise = fpath <> ":" <> b <> "-" <> e
ppLocation fpath (Local b e) =
opt (fpath/="") (fpath <> ":") <> b <> opt (b/=e) ("-" <> e)
where
opt False x = empty
opt True x = x
ppL (L loc x) msg = hang (loc<>":") 4 ("In"<+>x<>":"<+>msg)
ppL (L loc x) msg = hang (ppLocation "" loc<>":") 4
("In"<+>x<>":"<+>msg)
instance Pretty Location where pp = ppLocation ""
instance Pretty a => Pretty (L a) where pp (L loc x) = loc<>":"<>x

10
src/compiler/GF/Infra/Option.hs
View File

@@ -178,7 +178,8 @@ data Flags = Flags {
optHeuristicFactor :: Maybe Double,
optCaseSensitive :: Bool,
optPlusAsBind :: Bool,
optJobs :: Maybe (Maybe Int)
optJobs :: Maybe (Maybe Int),
optTrace :: Bool
}
deriving (Show)
@@ -289,7 +290,8 @@ defaultFlags = Flags {
optHeuristicFactor = Nothing,
optCaseSensitive = True,
optPlusAsBind = False,
optJobs = Nothing
optJobs = Nothing,
optTrace = False
}
-- | Option descriptions
@@ -318,6 +320,8 @@ optDescr =
Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
-- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
@@ -383,7 +387,6 @@ optDescr =
dumpOption "refresh" Refresh,
dumpOption "opt" Optimize,
dumpOption "canon" Canon
]
where phase x = set $ \o -> o { optStopAfterPhase = x }
mode x = set $ \o -> o { optMode = x }
@@ -406,6 +409,7 @@ optDescr =
Just i -> set $ \o -> o { optVerbosity = i }
Nothing -> fail $ "Bad verbosity: " ++ show v
cpu x = set $ \o -> o { optShowCPUTime = x }
-- trace x = set $ \o -> o { optTrace = x }
gfoDir x = set $ \o -> o { optGFODir = Just x }
outFmt x = readOutputFormat x >>= \f ->
set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }