From 35be1828241bb8dacdf326810af388b7b349e591 Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 28 Sep 2015 22:23:56 +0000 Subject: [PATCH] Preliminary new shell feature: cc -trace. 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". --- src/compiler/GF/Command/SourceCommands.hs | 23 ++++--- .../GF/Compile/Compute/ConcreteNew.hs | 67 ++++++++++++++----- src/compiler/GF/Compile/Compute/Predef.hs | 6 +- src/compiler/GF/Compile/Compute/Value.hs | 2 +- src/compiler/GF/Grammar/Grammar.hs | 4 +- src/compiler/GF/Grammar/Predef.hs | 1 + src/compiler/GF/Infra/Location.hs | 16 +++-- src/compiler/GF/Infra/Option.hs | 10 ++- 8 files changed, 89 insertions(+), 40 deletions(-) diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs index 0aedd5ddf..7d882e262 100644 --- a/src/compiler/GF/Command/SourceCommands.hs +++ b/src/compiler/GF/Command/SourceCommands.hs @@ -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 diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index 54e57478e..eec9f446c 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -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) diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index 0900f3665..0e02402f7 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -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 diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index 9bc258562..1cf1d88ee 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 6f254e7d3..587b09a9f 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -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) diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs index e330f583c..95bdb1101 100644 --- a/src/compiler/GF/Grammar/Predef.hs +++ b/src/compiler/GF/Grammar/Predef.hs @@ -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! diff --git a/src/compiler/GF/Infra/Location.hs b/src/compiler/GF/Infra/Location.hs index 36bfab044..0bf85b37f 100644 --- a/src/compiler/GF/Infra/Location.hs +++ b/src/compiler/GF/Infra/Location.hs @@ -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 + diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index a9a517a6e..48cb25cc7 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -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] }