jvm-parser (empty) → 0.2.1
raw patch · 7 files changed
+2732/−0 lines, 7 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, containers, data-binary-ieee754, fgl, fingertree, pretty, zlib
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- jvm-parser.cabal +37/−0
- src/Language/JVM/CFG.hs +736/−0
- src/Language/JVM/Common.hs +413/−0
- src/Language/JVM/JarReader.hs +223/−0
- src/Language/JVM/Parser.hs +1291/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012-2014, Galois, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the names of the authors nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jvm-parser.cabal view
@@ -0,0 +1,37 @@+Name: jvm-parser+Version: 0.2.1+License: BSD3+License-file: LICENSE+Author: Galois, Inc.+Maintainer: atomb@galois.com+Copyright: (c) 2012-2014 Galois Inc.+Category: Language+Build-type: Simple+Cabal-version: >=1.8+Synopsis: A parser for JVM bytecode files+Description:+ A parser for JVM bytecode (.class and .jar) files++source-repository head+ type: git+ location: https://github.com/GaloisInc/jvm-parser.git++Library+ Hs-source-dirs: src+ Exposed-modules: Language.JVM.CFG+ Language.JVM.Common+ Language.JVM.JarReader+ Language.JVM.Parser++ Ghc-options: -Wall++ Build-depends: array,+ base >= 4.0.0.0 && < 5.0.0.0,+ binary,+ bytestring,+ containers,+ data-binary-ieee754,+ fgl,+ fingertree,+ zlib,+ pretty
+ src/Language/JVM/CFG.hs view
@@ -0,0 +1,736 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, OverloadedStrings #-}++{- |+Module : Language.JVM.CFG+Copyright : Galois, Inc. 2012-2014+License : BSD3+Maintainer : atomb@galois.com+Stability : provisional+Portability : non-portable++Control Flow Graphs of JVM bytecode. For now, this module simply builds CFGs+from instruction streams and does post-dominator analysis.+-}++module Language.JVM.CFG+ ( -- * Basic blocks+ -- $basicblocks+ BasicBlock(bbId, bbInsts)+ , BBId(..)+ , ppBBId++ -- * Control flow graphs+ , CFG(bbById, bbByPC, nextPC, allBBs)+ , buildCFG+ , cfgInstByPC+ , ppBB+ , ppInst+ , cfgToDot+ , isImmediatePostDominator+ , getPostDominators+ )+where++import Control.Arrow (second)+import Data.Array+import qualified Data.Foldable as DF+import Data.Graph.Inductive+import qualified Data.IntervalMap.FingerTree as I+import Data.IntervalMap.FingerTree (IntervalMap, Interval(..))+import Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Prelude hiding (rem)+import Text.PrettyPrint++import Language.JVM.Common++-- import Debug.Trace++--------------------------------------------------------------------------------+-- Control flow graph construction++data CFG = CFG+ { bbById :: BBId -> Maybe BasicBlock+ , bbByPC :: PC -> Maybe BasicBlock+ , nextPC :: PC -> Maybe PC+ , allBBs :: [BasicBlock]+ , bbSuccs :: [(BBId, BBId)]+ , preds :: BBId -> [BBId]+ , succs :: BBId -> [BBId]+ , graph :: Gr BBId ()+ , nodeMap :: NodeMap BBId+ , ipdoms :: M.Map BBId BBId+ , pdoms :: M.Map BBId [BBId]+ }++entryBlock, exitBlock :: BasicBlock+entryBlock = BB BBIdEntry []+exitBlock = BB BBIdExit []++-- | Build a control-flow graph from an instruction stream.+-- We assume that the first instruction in the instruction stream is the only+-- external entry point in the sequence (typically, the method entry point)+buildCFG :: ExceptionTable -> InstructionStream -> CFG+buildCFG extbl istrm =+ -- trace ("calculated branch targets: " ++ show btm) $+ -- trace ("BBs:\n" ++ unlines (map ppBB (DF.toList finalBlocks))) cfg `seq`+ -- trace ("bbSuccs = " ++ show (bbSuccs cfg)) $+ -- trace ("bbPreds = " ++ show (map (\(a,b) -> (b,a)) (bbSuccs cfg))) $+ -- trace (render $ text "pdoms:" <+> vcat (map (\(n, pds) -> ppBBId n <+> (brackets . sep . punctuate comma . map ppBBId $ pds)) (M.toList (pdoms cfg)))) $+-- let dot = cfgToDot extbl cfg "???" in+-- trace ("dot:\n" ++ dot) $+ cfg+ where+ cfg = CFG {+ bbByPC = \pc ->+ if pc < firstPC || pc > lastPC+ then Nothing+ else case I.search pc finalBlocks of+ [(_, bb)] -> Just bb+ [] -> Nothing+ _ -> error $ "bbByPC: internal: "+ ++ "multiple interval match"+ , bbById = \bbid -> case bbid of+ BBId pc -> bbByPC cfg pc+ BBIdEntry -> Just entryBlock+ BBIdExit -> Just exitBlock+ , nextPC = \pc -> case bbByPC cfg pc of+ Nothing -> Nothing+ Just bb -> case bbSuccPC bb pc of+ Nothing ->+ -- The given PC has no successor in 'bb', so it must be the leader+ -- PC of the next BB encountered during findNextBB.+ let findNextBB i | i > lastPC = Nothing+ | otherwise = case bbByPC cfg i of+ Just _ -> Just i+ Nothing -> findNextBB (i + 1)+ in findNextBB (pc + 1)+ jpc -> jpc+ , allBBs = entryBlock : exitBlock : DF.toList finalBlocks+ , bbSuccs = (\f -> DF.foldr f [] finalBlocks) $ \bb acc ->+ let newSuccs =+ -- Identify a flow edge from bb to x when x's leader is a branch+ -- target of bb's terminator+ (map (\bt -> case bbByPC cfg bt of+ Nothing -> error "newSuccs: internal: invalid BBId"+ Just sbb -> (bbId bb, bbId sbb)+ )+ (brTargets $ terminatorPC bb)+ )+ +++ -- Identify a flow edge from bb to x when bb's terminator+ -- doesn't break the control flow path x's leader is the+ -- instruction successor of bb's terminator.+ case do+ let tpc = terminatorPC bb+ breaksCFP <- breaksControlFlow `fmap` bbInstByPC bb tpc+ if breaksCFP+ then Nothing+ else bbByPC cfg =<< nextPC cfg tpc+ of+ Nothing -> []+ Just nbb -> [(bbId bb, bbId nbb)]+ in+ -- NB: Hook up entry/exit blocks here+ (if leaderPC bb == firstPC then ((BBIdEntry, bbId bb) :) else id) $+ case newSuccs of+ [] -> (bbId bb, BBIdExit) : acc+ _ -> newSuccs ++ acc+ , preds = \bbid ->+ case bbById cfg bbid of+ Nothing -> error "CFG.preds: invalid BBId"+ Just _ -> map fst $ filter ((== bbid) . snd) $ bbSuccs cfg+ , succs = \bbid ->+ case bbById cfg bbid of+ Nothing -> error "CFG.succs: invalid BBId"+ Just _ -> map snd $ filter ((== bbid) . fst) $ bbSuccs cfg+ , graph = gr+ , nodeMap = nm+ , ipdoms = M.fromList . map pairFromInts . ipdom $ gr+ , pdoms = M.fromList . map adjFromInts . pdom $ gr+ }++ (gr, nm) = buildGraph cfg+ -- post-dominators are just dominators where the exit is the root+ ipdom = flip iDom (fst $ mkNode_ nm BBIdExit) . grev+ pdom = flip dom (fst $ mkNode_ nm BBIdExit) . grev++ pairFromInts (n, n') = (lkup n, lkup n')+ lkup n = fromMaybe (modErr "found node not in graph") $ lab gr n+ --adjToInts (n, ns) = (fromEnum n, map fromEnum ns)+ adjFromInts (n, ns) = (lkup n, map lkup ns)+ finalBlocks = blocks+ $ foldr+ process+ (BBInfo I.empty (BB (BBId firstPC) []) False)+ rinsts+ --+ process i@(pc,_) bbi = processInst+ (lastWasBranch bbi || isBrTarget pc)+ (isBrInst pc)+ firstPC lastPC i bbi+ -- instruction sequence fixup & reordering+ rinsts@((lastPC, _):_) = reverse insts+ insts@((firstPC, _):_) = map fixup $ filter valid $ assocs istrm+ where+ valid (_, Just{}) = True+ valid _ = False+ fixup (pc, Just i) = (pc, i)+ fixup _ = error "impossible"+ --+ isBrInst pc = not . null $ brTargets pc+ isBrTarget pc = pc `elem` concat (M.elems btm)+ btm = mkBrTargetMap extbl istrm+ brTargets pc = maybe [] id $ M.lookup pc btm++-- | We want to keep the node map around to look up specific nodes+-- later, even though I think we only do that once+buildGraph :: CFG -> (Gr BBId (), NodeMap BBId)+buildGraph cfg = (mkGraph ns es, nm)+ where (ns, nm) = mkNodes new (map bbId . allBBs $ cfg)+ es = fromMaybe (modErr "edge with unknown nodes")+ $ mkEdges nm edgeTriples+ edgeTriples :: [(BBId, BBId, ())] -- ready to become UEdges+ edgeTriples = map (\(n1, n2) -> (n1, n2, ())) (bbSuccs cfg)++-- | @isImmediatePostDominator g x y@ returns @True@ if @y@+-- immediately post-dominates @x@ in control-flow graph @g@.+isImmediatePostDominator :: CFG -> BBId -> BBId -> Bool+isImmediatePostDominator cfg bb bb' =+ maybe False (== bb') . M.lookup bb . ipdoms $ cfg++-- | Calculate the post-dominators of a given basic block+getPostDominators :: CFG -> BBId -> [BBId]+getPostDominators cfg bb = M.findWithDefault [] bb (pdoms cfg)++--------------------------------------------------------------------------------+-- $basicblocks+--+-- Our notion of basic block is fairly standard: a maximal sequence of+-- instructions that that can only be entered at the first of them and existed+-- only from the last of them. I.e., a contiguous sequence of instructions that+-- neither branch or are themselves branch targets.+--+-- The first instruction in a basic block (i.e., a "leader") may be (a) a method+-- entry point, (b) a branch target, or (c) an instruction immediately following+-- a branch/return.+--+-- To identify constituent basic blocks of a given instruction sequence, we+-- identify leaders and then, for each leader, include in its basic block all+-- instructions, in order, that intervene it and the next leader or the end of+-- the instruction sequence, whichever comes first.++-- | Identifies basic blocks by their position+-- in the instruction stream, or by the special+-- `BBIdEntry` or `BBIdExit` constructors.+data BBId = BBIdEntry | BBIdExit | BBId PC+ deriving (Eq, Ord, Show)++ppBBId :: BBId -> Doc+ppBBId bbid = case bbid of+ BBIdEntry -> "BB%entry"+ BBIdExit -> "BB%exit"+ BBId pc -> "BB%" <> int (fromIntegral pc)++instance Enum BBId where+ toEnum 0 = BBIdEntry+ toEnum 1 = BBIdExit+ toEnum n = BBId (fromIntegral n - 2)+ fromEnum BBIdEntry = 0+ fromEnum BBIdExit = 1+ fromEnum (BBId n) = fromIntegral n + 2++-- | A basic block consists of an identifier and+-- the instructions contained in that block.+data BasicBlock = BB+ { bbId :: BBId+ , bbInsts :: [(PC, Instruction)]+ }+ deriving (Show)++data BBInfo = BBInfo+ { blocks :: IntervalMap PC BasicBlock+ , currBB :: BasicBlock+ , lastWasBranch :: Bool -- True iff the last instruction examined was a+ -- branch/return for bb splitting purposes+ }++-- NB: We're punting on explicit bb splits/cfg edges on thrown exceptions and+-- instructions that can raise exceptions in the presence of a handler for the+-- time being.+processInst :: Bool -- ^ Is the given instruction a leader?+ -> Bool -- ^ Is the given instruction a branch?+ -> PC -- ^ Value of first PC in instruction sequence+ -> PC -- ^ Value of last PC in instruction sequence+ -> (PC, Instruction) -- ^ Current PC and instruction+ -> BBInfo -- ^ BB accumulator+ -> BBInfo+processInst isLeader isBranchInst firstPC lastPC (pc, inst) bbi =+ let bbi' = if isLeader then newBB else noNewBB+ in bbi'+ { lastWasBranch = isBranchInst || breaksControlFlow inst+ , blocks = if pc == lastPC+ then mk (currBB bbi') `I.union` blocks bbi'+ else blocks bbi'+ }+ where+ mk bb = let bb' = bb{ bbInsts = reverse (bbInsts bb) } in+ I.singleton (bbInterval bb') bb'+ addInst bb = bb { bbInsts = (pc, inst) : bbInsts bb }+ noNewBB = bbi { currBB = addInst (currBB bbi) }+ newBB+ | pc == firstPC = noNewBB+ | otherwise = bbi+ { blocks = mk (currBB bbi) `I.union` blocks bbi+ , currBB = addInst (BB (BBId pc) [])+ }++--------------------------------------------------------------------------------+-- Branch target calculation+--+-- Most branch targets can be determined by simple inspection of a given+-- instruction. A notable (and unfortunate) exception is determining the+-- targets of a 'ret' instruction. Since the address to which a ret jumps is a+-- first-class value, we need to do some dataflow analysis to figure out the+-- potential targets. Note that we make a few simplifying concessions, e.g.,+-- that jsr targets are always astores and that the bytecode we're analyzing+-- passes bytecode verification (e.g., to ensure that two subroutines may not+-- share a 'ret', and so forth).+--+-- We do a (fairly sparse) abstract execution of the method, tracking the state+-- pertaining to jsr/ret pairings along all execution paths.++mkBrTargetMap :: ExceptionTable -> InstructionStream -> Map PC [PC]+mkBrTargetMap extbl istrm = foldr f M.empty istrm'+ where+ f (pc, i) acc = maybe acc (\v -> M.insert pc v acc) $ getBrPCs i+ istrm'@((firstPC,_):_) = assocs istrm+ --+ getBrPCs Nothing = Nothing+ getBrPCs (Just i) =+ case i of+ Goto pc -> Just [pc]+ If_acmpeq pc -> Just [pc]+ If_acmpne pc -> Just [pc]+ If_icmpeq pc -> Just [pc]+ If_icmpne pc -> Just [pc]+ If_icmplt pc -> Just [pc]+ If_icmpge pc -> Just [pc]+ If_icmpgt pc -> Just [pc]+ If_icmple pc -> Just [pc]+ Ifeq pc -> Just [pc]+ Ifne pc -> Just [pc]+ Iflt pc -> Just [pc]+ Ifge pc -> Just [pc]+ Ifgt pc -> Just [pc]+ Ifle pc -> Just [pc]+ Ifnonnull pc -> Just [pc]+ Ifnull pc -> Just [pc]+ Jsr pc -> Just [pc]+ Ret{} ->+ let xfer = retTargetXfer extbl istrm in+ case doFlow xfer M.empty [(Just $ firstPC, [])] [] of+ [] -> error "Internal: dataflow analysis yielded no targets for ret"+ bs -> Just $ map snd bs+ Lookupswitch dflt tgts -> Just $ dflt : map snd tgts+ Tableswitch dflt _ _ tgts -> Just $ dflt : tgts+ _ -> Nothing++type XferF state acc = acc -> state -> (acc, [state])++-- | A simple worklist-based propagator for dataflow analysis+doFlow :: (Eq state, Ord state{-, Show state-}) =>+ XferF state acc -- ^ the state transfer function+ -> Map state () -- ^ the seen states map+ -> [state] -- ^ states worklist+ -> acc -- ^ accumulated dataflow result+ -> acc+doFlow _ _ [] acc = acc+doFlow xfer seen !(curr:rem) !acc =+ let (acc', new') = filter (`M.notMember` seen) `second` xfer acc curr+ in+-- trace ("doFlow step: worklist is: " ++ show (rem ++ new)) $+ doFlow xfer (foldr (flip M.insert ()) seen new') (rem ++ new') acc'++-- We represent the dataflow state before execution of an instruction at PC 'p'+-- by (Just p, L), where L is a relation between local variable indices and+-- return address values. States of the form (Nothing, _) denote termination.++type BrTargetState = (Maybe PC, [(LocalVariableIndex, PC)])++retTargetXfer :: ExceptionTable+ -> InstructionStream+ -> XferF BrTargetState [(PC, PC)]+retTargetXfer _ _ acc (Nothing, _) = (acc, [])+retTargetXfer extbl istrm acc (Just pc, localr) = xfer (lkup pc)+ where+ succPC = safeNextPcPrim istrm+ ssuccPC = maybe (error $ "btx: invalid succPC") id . succPC+ lkup p = maybe (error $ "btx: Invalid inst @ " ++ show p) id (istrm ! p)+ --+ xfer (Jsr label) = case lkup label of+ -- inst(p) = jsr(label) && inst(label) = astore i+ Astore i -> (acc, [(succPC label, (i, ssuccPC pc) : localr)])+ -- next state: the call of the referent subroutine (after+ -- its astore leader) with the successor of the jsr stored+ -- into the local specified by the astore+ _ -> error "btx: Assumed jsr targets are always Astore"+ --+ xfer (Ret k) = case lookup k localr of+ Just q -> ((pc, q) : acc, [(Just q, localr \\ [(k, q)])])+ -- inst(p) = ret k && L(k) = q; this is where we detect that+ -- this ret instruction branches to q along the control flow+ -- path we've been following. Record this fact in 'acc' and+ -- then follow the jump back to the jsr succ.+ Nothing -> error $ "btx: No retaddr at lidx " ++ show k+ --+ xfer inst | canThrowException inst =+ -- continue dataflow analysis at the next instruction (unless we're+ -- terminating this cfp here) and also at each exception handler that+ -- /may/ fire upon execution of the current instruction+ ( acc+ , let getHndlrPC (ExceptionTableEntry _ _ h _) = h+ ts = map (flip (,) localr . Just . getHndlrPC)+ . filter (ehCoversPC pc)+ $ extbl+ in+ if breaksControlFlow inst+ then ts -- terminate this cfp, but still evaluate exception cfps+ else (succPC pc, localr) : ts -- next inst + exception cfps+ )+ --+ xfer _ = (acc, [(succPC pc, localr)]) -- continue++--------------------------------------------------------------------------------+-- Utility functions++leaderPC :: BasicBlock -> PC+leaderPC BB{ bbInsts = [] } = error "internal: leaderPC on empty BB"+leaderPC bb = fst . head . bbInsts $ bb++terminatorPC :: BasicBlock -> PC+terminatorPC BB { bbInsts = [] } = error "internal: terminatorPC on empty BB"+terminatorPC bb = fst . last . bbInsts $ bb++-- | fetch an instruction from a CFG by position+cfgInstByPC :: CFG -> PC -> Maybe Instruction+cfgInstByPC cfg pc = bbByPC cfg pc >>= flip bbInstByPC pc++bbInstByPC :: BasicBlock -> PC -> Maybe Instruction+bbInstByPC bb pc = lookup pc (bbInsts bb)++bbInterval :: BasicBlock -> Interval PC+bbInterval bb = Interval (leaderPC bb) (terminatorPC bb)++bbPCs :: BasicBlock -> [PC]+bbPCs = map fst . bbInsts++bbSuccPC :: BasicBlock -> PC -> Maybe PC+bbSuccPC bb pc =+ case drop 1 $ dropWhile (/= pc) $ map fst $ bbInsts bb of+ [] -> Nothing+ (succPC:_) -> Just succPC++ehCoversPC :: PC -> ExceptionTableEntry -> Bool+ehCoversPC pc (ExceptionTableEntry s e _ _) = pc >= s && pc <= e++ehsForBB :: ExceptionTable -> BasicBlock -> ExceptionTable+ehsForBB extbl bb =+ nub $ concatMap (\pc -> filter (ehCoversPC pc) extbl) (bbPCs bb)++modErr :: String -> a+modErr msg = error $ "Language.JVM.CFG: " ++ msg++--------------------------------------------------------------------------------+-- Pretty-printing++ppBB :: BasicBlock -> String+ppBB bb =+ "BB(" ++ show (bbId bb) ++ "):\n"+ ++ unlines (map (\(pc,inst) -> " " ++ show pc ++ ": " ++ ppInst inst) (bbInsts bb))++ppInst :: Instruction -> String+ppInst (Invokevirtual (ClassType cn) mk)+ = "Invokevirtual " ++ ppNm cn mk+ppInst (Invokespecial (ClassType cn) mk)+ = "Invokespecial " ++ ppNm cn mk+ppInst (Invokestatic cn mk)+ = "Invokestatic " ++ ppNm cn mk+ppInst (Invokeinterface cn mk)+ = "Invokeinterface " ++ ppNm cn mk+ppInst (Getfield fldId)+ = "Getfield " ++ ppFldId fldId+ppInst (Putfield fldId)+ = "Putfield " ++ ppFldId fldId+ppInst (New s)+ = "New " ++ (slashesToDots s)+ppInst (Ldc (String s))+ = "Ldc (String " ++ "\"" ++ s ++ "\")"+ppInst (Ldc (ClassRef s))+ = "Ldc (ClassRef " ++ slashesToDots s ++ ")"+ppInst (Getstatic fldId)+ = "Getstatic " ++ ppFldId fldId+ppInst (Putstatic fldId)+ = "Putstatic " ++ ppFldId fldId+ppInst i+ = show i++ppNm :: String -> MethodKey -> String+ppNm cn mk = slashesToDots cn ++ "." ++ methodKeyName mk++--------------------------------------------------------------------------------+-- .dot output++-- | Render the CFG of a method into Graphviz .dot format+cfgToDot+ :: ExceptionTable+ -> CFG + -> String -- ^ method name+ -> String+cfgToDot extbl cfg methodName =+ "digraph methodcfg {"+ ++ nl ++ "label=\"CFG for method '" ++ methodName ++ "'\";"+ ++ nl ++ intercalate nl (map renderBB (allBBs cfg) ++ map renderEdge (bbSuccs cfg))+ ++ "\n}"+ where+ nm BBIdEntry = "entry"+ nm BBIdExit = "exit"+ nm (BBId pc) = "BB_" ++ show pc+ nl = "\n "+ qnl = "\\n"+ renderBB bb = nm (bbId bb)+ ++ " [ shape=record, label=\"{"+ ++ intercalate qnl (ppLabel bb : map ppEntry (bbInsts bb))+ ++ "}\" ];"+ renderEdge (src,snk) = nm src ++ " -> " ++ nm snk ++ ";"+ ppEntry (pc,i) = show pc ++ ": " ++ ppInst i+ ppLabel bb = nm (bbId bb) ++ ": " ++ exhText bb+ exhText bb = case map snd . filter (p . fst) $ exhLabels of+ [] -> ""+ labels -> intercalate ", " labels+ where+ p pc = bbId bb /= BBIdEntry && bbId bb /= BBIdExit+ && leaderPC bb == pc+ exhLabels = nub $ (`concatMap` (allBBs cfg)) $ \bb ->+ case ehsForBB extbl bb of+ [] -> []+ ehs -> (`map` ehs) $ \eh ->+ ( handlerPc eh+ , "(H-" ++ maybe "All" show (catchType eh)+ ++ ": [" ++ show (startPc eh) ++ ","+ ++ show (endPc eh) ++ "])"+ )++--------------------------------------------------------------------------------+-- Instances++instance Show CFG where+ show cfg = "CFG{ allBBs = " ++ show (allBBs cfg) ++ " }"-- unlines $ map show $ allBBs cfg++instance Eq CFG where+ cfg1 == cfg2 = allBBs cfg1 == allBBs cfg2 && bbSuccs cfg1 == bbSuccs cfg2++instance Eq BasicBlock where+ bb1 == bb2 = bbId bb1 == bbId bb2++--------------------------------------------------------------------------------+-- Testing miscellany++_dummy_nowarn :: [a]+_dummy_nowarn =+ [ undefined test1, undefined test1Code, undefined test1cfg+ , undefined test2, undefined test2Code, undefined test2cfg+ , undefined test3, undefined test4, undefined allTests+ , undefined bbPCs, undefined ehsForBB+ , undefined test5Code, undefined test5cfg+ ]++test1 :: Bool+test1 = doFlow+ (retTargetXfer test1Extbl test1Code) -- xfer function over istream+ M.empty -- seen states+ [(Just 0, [])] -- initial state: PC 0, no locals+ [] -- branch relation+ == [(19,12),(19,7)]++test1cfg :: IO ()+test1cfg = mapM_ (putStrLn . ppBB) . allBBs $ buildCFG test1Extbl test1Code++-- test1Code is a rough sketch of code that might be generated for:+-- void tryFinally { try { something(); } finally { cleanup(); } }+test1Code :: InstructionStream+test1Code = array (0,19)+ [ (0, Just $ Aload 0) -- push 'this'; begin try clause+ , (1, Just $ placeholderVirtualCall) -- something()+ , (2, Nothing)+ , (3, Nothing)+ , (4, Just $ Jsr 14) -- invoke finally clause; end try clause+ , (5, Nothing)+ , (6, Nothing)+ , (7, Just $ Return) -- terminate normally+ , (8, Just $ Astore 1) -- exception handler begin+ , (9, Just $ Jsr 14) -- invoke finally clause+ , (10, Nothing)+ , (11, Nothing)+ , (12, Just $ Aload 1) -- push thrown value+ , (13, Just $ Athrow) -- Re-throw; exeception handler end+ , (14, Just $ Astore 2) -- Start of finally clause+ , (15, Just $ Aload 0) -- push 'this'+ , (16, Just $ placeholderVirtualCall) -- cleanup()+ , (17, Nothing)+ , (18, Nothing)+ , (19, Just $ Ret 2)+ ]+ where+ placeholderVirtualCall = Invokevirtual (ClassType "INVALID") $+ MethodKey "INVALID" [] Nothing++test1Extbl :: ExceptionTable+test1Extbl = [ExceptionTableEntry 0 4 8 Nothing]++--++test2 :: Bool -- [(PC,PC)]+test2 = doFlow+ (retTargetXfer test2Extbl test2Code) -- xfer function over istream+ M.empty -- seen states+ [(Just 0, [])] -- initial state: PC 0, no locals+ [] -- branch relation+ == [(31,19),(31,24)]++test2cfg :: IO ()+test2cfg = mapM_ (putStrLn . ppBB) $ allBBs $ buildCFG test2Extbl test2Code++-- test2Code is a rough sketch of code that might be generated for:+-- void tryCatchFinally() {+-- try { tryItOut(); }+-- catch (TestExc e) { handleExc(e); }+-- finally { wrapItUp(); }+-- }+--+test2Code :: InstructionStream+test2Code = array (0, 31)+ [ (0, Just $ Aload 0) -- start of try block+ , (1, placeholderVirtualCall) -- call tryItOut()+ , nop 2+ , nop 3+ , (4, Just $ Goto 16) -- jump to finally block call+ , nop 5+ , nop 6+ , (7, Just $ Astore 3) -- start of hndlr for TextExc exceptions+ , (8, Just $ Aload 0) -- push 'this'+ , (9, Just $ Aload 3) -- push thrown value+ , (10, placeholderVirtualCall) -- Invoke handler method+ , nop 11+ , nop 12+ , (13, Just $ Goto 16) -- jump to finally block call+ , nop 14+ , nop 15+ , (16, Just $ Jsr 26) -- call finally block+ , nop 17+ , nop 18+ , (19, Just Return) -- return after handling TestExc+ , (20, Just $ Astore 1) -- start of hndlr for non-TextExc exceptions+ , (21, Just $ Jsr 26) -- call finally block+ , nop 22+ , nop 23+ , (24, Just $ Aload 1) -- push thrown value+ , (25, Just Athrow) -- re-throw+ , (26, Just $ Astore 2) -- start of finally block+ , (27, Just $ Aload 0) -- push 'this'+ , (28, placeholderVirtualCall) -- call wrapItUp()+ , nop 29+ , nop 30+ , (31, Just $ Ret 2) -- return from finally block+ ]+ where+ nop pc = (pc, Nothing)+ placeholderVirtualCall = Just $ Invokevirtual (ClassType "INVALID") $+ MethodKey "INVALID" [] Nothing++test2Extbl :: ExceptionTable+test2Extbl = [ ExceptionTableEntry 0 4 7 (Just $ ClassType "java/blah/TestExc")+ , ExceptionTableEntry 0 16 20 Nothing+ ]++test3 :: Bool+test3 = sort (bbSuccs (buildCFG test1Extbl test1Code))+ == sort [ (BBIdEntry,BBId 0)+ , (BBId 0,BBId 14)+ , (BBId 7,BBIdExit)+ , (BBId 8,BBId 14)+ , (BBId 12,BBIdExit)+ , (BBId 14,BBId 12)+ , (BBId 14,BBId 7)+ ]++test4 :: Bool+test4 = sort (bbSuccs (buildCFG test2Extbl test2Code))+ == sort [ (BBId 0,BBId 16)+ , (BBId 7,BBId 16)+ , (BBId 16,BBId 26)+ , (BBId 19,BBIdExit)+ , (BBId 20,BBId 26)+ , (BBId 24,BBIdExit)+ , (BBId 26,BBId 19)+ , (BBId 26,BBId 24)+ , (BBIdEntry,BBId 0)+ ]++-- public static int f(int k)+-- {+-- int rslt = 0;+-- for (int i = 0; i < k; ++i) {+-- rslt++;+-- }+-- return rslt;+-- }+test5Code :: InstructionStream+test5Code = array (0,19)+ [ (0, Just $ Ldc (Integer 0))+ , (1, Just $ Istore 1)+ , (2, Just $ Ldc (Integer 0))+ , (3, Just $ Istore 2)+ , (4, Just $ Iload 2)+ , (5, Just $ Iload 0)+ , (6, Just $ If_icmpge 18)+ , (7, Nothing)+ , (8, Nothing)+ , (9, Just $ Iinc 1 1)+ , (10, Nothing)+ , (11, Nothing)+ , (12, Just $ Iinc 2 1)+ , (13, Nothing)+ , (14, Nothing)+ , (15, Just $ Goto 4)+ , (16, Nothing)+ , (17, Nothing)+ , (18, Just $ Iload 1)+ , (19, Just $ Ireturn)+ ]++test5cfg :: IO ()+test5cfg = mapM_ (putStrLn . ppBB) $ allBBs $ buildCFG [] test5Code++test5 :: Bool+test5 =+ (M.toAscList . ipdoms) cfg ==+ [ (BBIdEntry, BBId 0)+ , (BBId 0, BBId 4)+ , (BBId 4, BBId 18)+ , (BBId 9, BBId 4)+ , (BBId 18, BBIdExit)+ ] &&+ (M.toAscList . pdoms) cfg ==+ [ (BBIdEntry, [BBIdEntry, BBId 0, BBId 4, BBId 18, BBIdExit])+ , (BBIdExit, [BBIdExit])+ , (BBId 0, [BBId 0, BBId 4, BBId 18, BBIdExit])+ , (BBId 4, [BBId 4, BBId 18, BBIdExit])+ , (BBId 9, [BBId 9, BBId 4, BBId 18, BBIdExit])+ , (BBId 18, [BBId 18, BBIdExit])+ ] where cfg = buildCFG [] test5Code++allTests :: Bool+allTests = and [test1, test2, test3, test4, test5]
+ src/Language/JVM/Common.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Language.JVM.Common+Copyright : Galois, Inc. 2012-2014+License : BSD3+Maintainer : atomb@galois.com+Stability : stable+Portability : non-portable++Basic datatypes and utilities for the JVM parser.+-}++module Language.JVM.Common where++import Data.Array+import Data.Int+import Data.Word+import Text.PrettyPrint++-- | Replace '/' characters with '.' characters+slashesToDots :: String -> String+slashesToDots = map (\c -> if c == '/' then '.' else c)++-- | Replace '.' characters with '/' characters+dotsToSlashes :: String -> String+dotsToSlashes = map (\c -> if c == '.' then '/' else c)++-- | JVM Type+data Type+ = ArrayType Type+ | BooleanType+ | ByteType+ | CharType+ | ClassType String -- ^ ClassType with name of packages separated by slash '/'+ | DoubleType+ | FloatType+ | IntType+ | LongType+ | ShortType+ deriving (Eq, Ord)++stringTy :: Type+stringTy = ClassType "java/lang/String"++intArrayTy :: Type+intArrayTy = ArrayType IntType++byteArrayTy :: Type+byteArrayTy = ArrayType ByteType++charArrayTy :: Type+charArrayTy = ArrayType CharType++-- | Returns true if type is an integer value.+isIValue :: Type -> Bool+isIValue BooleanType = True+isIValue ByteType = True+isIValue CharType = True+isIValue IntType = True+isIValue ShortType = True+isIValue _ = False++-- | Returns true if type is a reference value.+isRValue :: Type -> Bool+isRValue (ArrayType _) = True+isRValue (ClassType _) = True+isRValue _ = False++-- | Returns true if Java type is a primitive type. Primitive types are+-- the Boolean type or numeric types.+isPrimitiveType :: Type -> Bool+isPrimitiveType (ArrayType _) = False+isPrimitiveType BooleanType = True+isPrimitiveType ByteType = True+isPrimitiveType CharType = True+isPrimitiveType (ClassType _) = False+isPrimitiveType DoubleType = True+isPrimitiveType FloatType = True+isPrimitiveType IntType = True+isPrimitiveType LongType = True+isPrimitiveType ShortType = True++-- | Returns number of bits that a Java type is expected to take on the stack.+-- Type should be a primitive type.+stackWidth :: Type -> Int+stackWidth BooleanType = 32+stackWidth ByteType = 32+stackWidth CharType = 32+stackWidth DoubleType = 64+stackWidth FloatType = 32+stackWidth IntType = 32+stackWidth LongType = 64+stackWidth ShortType = 32+stackWidth _ = error "internal: illegal type"++-- | Returns true if Java type denotes a floating point.+isFloatType :: Type -> Bool+isFloatType FloatType = True+isFloatType DoubleType = True+isFloatType _ = False++-- | Returns true if Java type denotes a reference.+isRefType :: Type -> Bool+isRefType (ArrayType _) = True+isRefType (ClassType _) = True+isRefType _ = False++-- | Unique identifier of field+data FieldId = FieldId {+ fieldIdClass :: !String -- ^ Class name+ , fieldIdName :: !String -- ^ Field name+ , fieldIdType :: !Type -- ^ Field type+ } deriving (Eq, Ord, Show)++ppFldId :: FieldId -> String+ppFldId fldId = slashesToDots (fieldIdClass fldId) ++ "." ++ fieldIdName fldId++-- MethodKey {{{1+-- | A unique identifier for looking up a method in a class.+data MethodKey = MethodKey {+ methodKeyName :: String+ , methodKeyParameterTypes :: [Type]+ , methodKeyReturnType :: Maybe Type+ } deriving (Eq, Ord, Show)++ppMethodKey :: MethodKey -> Doc+ppMethodKey (MethodKey name params ret) =+ text name+ <> (parens . commas . map ppType) params+ <> maybe "void" ppType ret+ where commas = sep . punctuate comma++-- | A value stored in the constant pool.+data ConstantPoolValue+ = Long Int64+ | Float Float+ | Double Double+ | Integer Int32+ | String String+ | ClassRef String+ deriving (Eq,Show)++-- | A local variable index.+type LocalVariableIndex = Word16++-- | A program counter value.+type PC = Word16++-- | A JVM Instruction+data Instruction+ = Aaload+ | Aastore+ | Aconst_null+ | Aload LocalVariableIndex+ -- Anewarray replaced by generalized Newarray+ | Areturn+ | Arraylength+ | Astore LocalVariableIndex+ | Athrow+ | Baload+ | Bastore+ -- Bipush replaced with Ldc+ | Caload+ | Castore+ | Checkcast Type+ | D2f+ | D2i+ | D2l+ | Dadd+ | Daload+ | Dastore+ | Dcmpg+ | Dcmpl+ -- Dconst_x has been replaced by Ldc+ | Ddiv+ | Dload LocalVariableIndex+ | Dmul+ | Dneg+ | Drem+ | Dreturn+ | Dstore LocalVariableIndex+ | Dsub+ | Dup+ | Dup_x1+ | Dup_x2+ | Dup2+ | Dup2_x1+ | Dup2_x2+ | F2d+ | F2i+ | F2l+ | Fadd+ | Faload+ | Fastore+ | Fcmpg+ | Fcmpl+ -- Fconst_x has been replaced by Ldc+ | Fdiv+ | Fload LocalVariableIndex+ | Fmul+ | Fneg+ | Frem+ | Freturn+ | Fstore LocalVariableIndex+ | Fsub+ -- | getfield instruction+ | Getfield FieldId+ | Getstatic FieldId+ | Goto PC+ -- Goto_w has been replaced with Goto+ | I2b+ | I2c+ | I2d+ | I2f+ | I2l+ | I2s+ | Iadd+ | Iaload+ | Iand+ | Iastore+ -- Iconst_x replaced with sipush+ | Idiv+ | If_acmpeq PC+ | If_acmpne PC+ | If_icmpeq PC+ | If_icmpne PC+ | If_icmplt PC+ | If_icmpge PC+ | If_icmpgt PC+ | If_icmple PC+ | Ifeq PC+ | Ifne PC+ | Iflt PC+ | Ifge PC+ | Ifgt PC+ | Ifle PC+ | Ifnonnull PC+ | Ifnull PC+ | Iinc LocalVariableIndex Int16+ | Iload LocalVariableIndex+ | Imul+ | Ineg+ | Instanceof Type+ | Invokeinterface String MethodKey+ | Invokespecial Type MethodKey+ | Invokestatic String MethodKey+ | Invokevirtual Type MethodKey+ | Ior+ | Irem+ | Ireturn+ | Ishl+ | Ishr+ | Istore LocalVariableIndex+ | Isub+ | Iushr+ | Ixor+ | Jsr PC+ | L2d+ | L2f+ | L2i+ | Ladd+ | Laload+ | Land+ | Lastore+ | Lcmp+ -- Lconst_x has been replaced by generalized Ldc+ -- Ldc, Ldc_w and Ldc2_w have been merged into single generalized Ldc+ | Ldc ConstantPoolValue+ | Ldiv+ | Lload LocalVariableIndex+ | Lmul+ | Lneg+ | Lookupswitch PC {-default -} [(Int32,PC)] {- (key, target) -}+ | Lor+ | Lrem+ | Lreturn+ | Lshl+ | Lshr+ | Lstore LocalVariableIndex+ | Lsub+ | Lushr+ | Lxor+ | Monitorenter+ | Monitorexit+ | Multianewarray Type Word8+ | New String+ -- The type is the type of the array.+ | Newarray Type+ | Nop+ | Pop+ | Pop2+ | Putfield FieldId+ | Putstatic FieldId+ | Ret LocalVariableIndex+ | Return+ | Saload+ | Sastore+ -- Sipush has been replced by ldc+ | Swap+ | Tableswitch PC Int32 Int32 [PC]+ deriving (Eq,Show)++-- | TODO: improve this+ppInstruction :: Instruction -> Doc+ppInstruction = text . show++-- | An entry in the exception table for a method+data ExceptionTableEntry = ExceptionTableEntry {+ -- | The starting program counter value where the exception handler applies+ startPc :: PC+ -- | The ending program counter value where the exception handler applies.+ , endPc :: PC+ -- | The program counter value to jump to when an exception is caught.+ , handlerPc :: PC+ -- | The type of exception that should be caught or Nothing if all types of+ -- exceptions should be caught.+ , catchType :: Maybe Type+ } deriving (Eq,Show)++type ExceptionTable = [ExceptionTableEntry]++type InstructionStream = Array PC (Maybe Instruction)++--------------------------------------------------------------------------------+-- Utility functions++canThrowException :: Instruction -> Bool+canThrowException Arraylength{} = True+canThrowException Checkcast{} = True+canThrowException Getfield{} = True+canThrowException Getstatic{} = True+canThrowException Idiv{} = True+canThrowException Invokeinterface{} = True+canThrowException Invokespecial{} = True+canThrowException Invokestatic{} = True+canThrowException Invokevirtual{} = True+canThrowException Irem{} = True+canThrowException Ldiv{} = True+canThrowException Lrem{} = True+canThrowException Monitorenter{} = True+canThrowException Monitorexit{} = True+canThrowException Multianewarray{} = True+canThrowException Newarray{} = True+canThrowException New{} = True+canThrowException Putfield{} = True+canThrowException Putstatic{} = True+canThrowException Athrow{} = True+canThrowException inst = isArrayLoad inst || isReturn inst++isArrayLoad :: Instruction -> Bool+isArrayLoad Aaload{} = True+isArrayLoad Aastore{} = True+isArrayLoad Baload{} = True+isArrayLoad Bastore{} = True+isArrayLoad Caload{} = True+isArrayLoad Castore{} = True+isArrayLoad Daload{} = True+isArrayLoad Dastore{} = True+isArrayLoad Faload{} = True+isArrayLoad Fastore{} = True+isArrayLoad Iaload{} = True+isArrayLoad Iastore{} = True+isArrayLoad Laload{} = True+isArrayLoad Lastore{} = True+isArrayLoad Saload{} = True+isArrayLoad Sastore{} = True+isArrayLoad _ = False++isReturn :: Instruction -> Bool+isReturn Areturn{} = True+isReturn Dreturn{} = True+isReturn Freturn{} = True+isReturn Ireturn{} = True+isReturn Lreturn{} = True+isReturn Return{} = True+isReturn _ = False++breaksControlFlow :: Instruction -> Bool+breaksControlFlow Jsr{} = True+breaksControlFlow Ret{} = True+breaksControlFlow Goto{} = True+breaksControlFlow Athrow{} = True+breaksControlFlow inst = isReturn inst++nextPcPrim :: InstructionStream -> PC -> PC+nextPcPrim istrm pc = findNext istrm (pc + 1)+ where findNext is i =+ case (is ! i) of+ Just _ -> i+ Nothing -> findNext is (i+1)++safeNextPcPrim :: InstructionStream -> PC -> Maybe PC+safeNextPcPrim istrm pc | pc <= snd (bounds istrm) = Just $ nextPcPrim istrm pc+ | otherwise = Nothing++--------------------------------------------------------------------------------+-- Instances++instance Show Type where+ show ByteType = "byte"+ show CharType = "char"+ show DoubleType = "double"+ show FloatType = "float"+ show IntType = "int"+ show LongType = "long"+ show (ClassType st) = slashesToDots st+ show ShortType = "short"+ show BooleanType = "boolean"+ show (ArrayType tp) = (show tp) ++ "[]"++ppType :: Type -> Doc+ppType = text . show
+ src/Language/JVM/JarReader.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Language.JVM.JarReader+Copyright : Galois, Inc. 2012-2014+License : BSD3+Maintainer : atomb@galois.com+Stability : stable+Portability : non-portable++A quick-n-dirty reader for JAR files. MANY keep-it-simple concessions have+been made regarding the zip structure of jars (e.g. no ZIP64, Deflate-type+compression only, etc., etc.). Please don't mistake this module for any kind+of fully-fledged unzip implementation!++Info on the zip file format can be found at:+<http://www.pkware.com/documents/casestudies/APPNOTE.TXT>+-}+module Language.JVM.JarReader+ ( JarReader(..)+ , addJar+ , dumpJarReader+ , loadClassFromJar+ , newJarReader+ ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Binary.Get+import Data.Bits+import Data.ByteString.Lazy (ByteString, isSuffixOf, hGet)+import Data.ByteString.Lazy.Char8 (pack, unpack)+import Data.Map (Map)+import Data.Word+import System.IO++import qualified Codec.Compression.Zlib.Raw as Zlib+import qualified Control.Exception as CE+import qualified Data.List as L+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M++import Language.JVM.Parser++-- import Debug.Trace++-- | Datatype representing a collection of .jar archives.+-- Classfiles can be loaded from a JarReader using 'loadClassFromJar'.+newtype JarReader = JR+ { unJR :: Map ByteString (FilePath, DirEnt) }+ deriving (Show)++-- | Print all the directory entries known to this JarReader+-- onto the console+dumpJarReader :: JarReader -> IO ()+dumpJarReader jr = mapM_ putStrLn (map unpack . M.keys $ unJR jr)++emptyJarReader :: JarReader+emptyJarReader = JR (M.empty)++-- | Load a class from the given JarReader.+loadClassFromJar+ :: String -- ^ Class file name to load+ -> JarReader+ -> IO (Maybe Class)+loadClassFromJar clNm jr = do+ let k = pack $ clNm ++ (if ".class" `L.isSuffixOf` clNm then "" else ".class")+ case M.lookup k (unJR jr) of+ Nothing -> return Nothing+ Just (jarFn, dent) -> withBinaryFile jarFn ReadMode $ \h -> do+ let parseBytes (n::Int) p = runGet p <$> hGet h (fromIntegral n)+ hSeek h AbsoluteSeek $ fromIntegral $ dentRelOff dent++ sig <- parseBytes 4 getWord32le+ CE.assert (sig == lclHdrSig) $ return ()++ -- Skip header bytes (26 bytes of redundant/irrelevant/unused data), plus+ -- the variable-size fields (filename and "extra")+ hSeek h RelativeSeek $ fromIntegral $+ 26 + dentFilenameLen dent + dentXtraFldLen dent++ let uncompSz = fromIntegral $ dentUncompSz dent+ compSz = fromIntegral $ dentCompSz dent++ bytes <- case dentCompMethod dent of+ 0x0 -> hGet h uncompSz+ 0x8 -> Zlib.decompress <$> hGet h compSz+ _ -> compTypeNotSupported+ CE.assert (LBS.length bytes == fromIntegral uncompSz) $ return ()+ let cl = runGet getClass bytes+ cl `seq` return (Just cl)++-- | Create a new `JarReader` from the given collection of .jar archives+newJarReader :: [FilePath] -> IO JarReader+newJarReader = foldM addJar emptyJarReader++-- | Add a .jar archive to a `JarReader`+addJar :: JarReader -> FilePath -> IO JarReader+addJar jr fn = do+ h <- openBinaryFile fn ReadMode+ let+ parseBytes n p = runGet p <$> hGet h (fromIntegral n)+ seekFromEnd = hSeek h SeekFromEnd . negate {- Grr! -} . fromIntegral+ seekFromStart = hSeek h AbsoluteSeek . fromIntegral+ findDirEnd (off::Int) = do+ seekFromEnd off+ s <- parseBytes (4::Int) getWord32le+ if s == dirEndSig then return off else findDirEnd (off + 1)++ seekFromEnd =<< findDirEnd 4+ sz <- hFileSize h+ dend <- runGet dirEnd <$> hGet h (fromIntegral sz)++ -- no support for a "multidisk" archive+ CE.assert (dendDiskEntryCnt dend == dendEntryCnt dend) $ return ()+ CE.assert (dendDiskNum dend == dendStartDiskNum dend) $ return ()++ seekFromStart (dendDirStartOff dend)+ JR+ . (`M.union` unJR jr) -- left biased: use newer jar's value on collision+ . M.fromList+ . map ((dentFilename &&& (,) fn) . checkBitFlagAndSizes)+ . filter (isSuffixOf (pack ".class") . dentFilename)+ <$> let numHdrs = fromIntegral (dendEntryCnt dend) in do+ parseBytes (dendDirSize dend) (replicateM numHdrs dirEnt)++-- | NB: We expect that the given class files do not have the (un)compressed+-- sizes stored in the data descriptor segment.+checkBitFlagAndSizes :: DirEnt -> DirEnt+checkBitFlagAndSizes d =+ if (dentBitFlag d .&. 0x8 == 0+ || (dentCompSz d > 0 && dentUncompSz d > 0))+ then d+ else ddSizesNotSupported++-- A central directory entry+data DirEnt = DirEnt+ { dentBitFlag :: !Word16+ , dentCompMethod :: !Word16+ , dentCompSz :: !Word32+ , dentUncompSz :: !Word32+ , dentRelOff :: !Word32+ , dentFilenameLen :: !Word16+ , dentXtraFldLen :: !Word16+ , dentFilename :: !ByteString+ }+ deriving (Show)++dirEnt :: Get DirEnt+dirEnt = do+ sig <- getWord32le+ CE.assert (sig == dirEntSig) $ return ()+ skip 2 -- version made by+ skip 2 -- version needed to extract+ bitFlag <- getWord16le+ compMeth <- getWord16le+ -- "deflate" type compression or uncompressed only+ when (compMeth /= 0x0 && compMeth /= 0x8) compTypeNotSupported+ skip 2 -- last mod file time+ skip 2 -- last mod file date+ skip 4 -- crc-32+ compSz <- getWord32le+ uncompSz <- getWord32le+ fnameLen <- getWord16le+ xfldLen <- getWord16le+ cmntLen <- fromIntegral <$> getWord16le+ skip 2 -- disk number start+ skip 2 -- internal file attributes+ skip 4 -- external file attributes+ relOff <- getWord32le+ fname <- getLazyByteString (fromIntegral fnameLen)+-- when (bitFlag .&. 0x8 /= 0 && (uncompSz == 0 || compSz == 0)) $ do+-- trace ("viol: " ++ show fname ++ ", uncompSz = " ++ show uncompSz) $ return ()+ skip (fromIntegral xfldLen) -- extra field+ skip cmntLen -- file comment++ return $ DirEnt bitFlag compMeth compSz uncompSz relOff fnameLen xfldLen fname++-- | The trailer of the central directory section+data DirEnd = DirEnd+ { dendDiskNum :: !Word16+ , dendStartDiskNum :: !Word16+ , dendDiskEntryCnt :: !Word16+ , dendEntryCnt :: !Word16+ , dendDirSize :: !Word32+ , dendDirStartOff :: !Word32+ , _dendComment :: !(Maybe ByteString)+ }+ deriving (Show)++dirEnd :: Get DirEnd+dirEnd = do+ sig <- getWord32le+ CE.assert (sig == dirEndSig) $ return ()+ DirEnd+ <$> getWord16le+ <*> getWord16le+ <*> getWord16le+ <*> getWord16le+ <*> getWord32le+ <*> getWord32le+ <*> do clen <- getWord16le+ if clen > 0+ then Just <$> getRemainingLazyByteString+ else return Nothing++dirEndSig :: Word32+dirEndSig = 0x06054b50++dirEntSig :: Word32+dirEntSig = 0x02014b50++lclHdrSig :: Word32+lclHdrSig = 0x04034b50++compTypeNotSupported :: a+compTypeNotSupported =+ error $ "JAR processing error: data descriptor sizes encoding unsupported"++ddSizesNotSupported :: a+ddSizesNotSupported =+ error $ "JAR processing error: data descriptor sizes encoding unsupported"
+ src/Language/JVM/Parser.hs view
@@ -0,0 +1,1291 @@+{- |+Module : Language.JVM.Parser+Copyright : Galois, Inc. 2012-2014+License : BSD3+Maintainer : atomb@galois.com+Stability : stable+Portability : portable++Parser for the JVM bytecode format.+-}++module Language.JVM.Parser (+ -- * Basic types+ Type(..)+ , isIValue+ , isPrimitiveType+ , isRValue+ , stackWidth+ , isFloatType+ , isRefType+ , ConstantPoolValue(..)+ , Attribute(..)+ , Visibility(..)+ -- * SerDes helpers+ , getClass+ -- * Class declarations+ , Class+ , className+ , superClass+ , classIsPublic+ , classIsFinal+ , classIsInterface+ , classIsAbstract+ , classHasSuperAttribute+ , classInterfaces+ , classFields+ , classMethods+ , classAttributes+ , loadClass+ , lookupMethod+ , showClass+ -- * Field declarations+ , FieldId(..)+ , Field+ , fieldName+ , fieldType+ , fieldVisibility+ , fieldIsStatic+ , fieldIsFinal+ , fieldIsVolatile+ , fieldIsTransient+ , fieldConstantValue+ , fieldIsSynthetic+ , fieldIsDeprecated+ , fieldIsEnum+ , fieldSignature+ , fieldAttributes+ -- * Method declarations+ , MethodKey(..)+ , makeMethodKey+ , Method+ , methodName+ , methodParameterTypes+ , localIndexOfParameter+ , methodReturnType+ , methodMaxLocals+ , methodIsNative+ , methodIsAbstract+ , methodBody+ , MethodBody(..)+ , methodExceptionTable+ , methodKey+ , methodIsStatic+ -- ** Instruction declarations+ , LocalVariableIndex+ , LocalVariableTableEntry(..)+ , PC+ , Instruction(..)+ , lookupInstruction+ , nextPc+ -- ** Exception table declarations+ , ExceptionTableEntry+ , catchType+ , startPc+ , endPc+ , handlerPc+ -- ** Misc utility functions/values+ , byteArrayTy+ , charArrayTy+ , getElemTy+ , intArrayTy+ , stringTy+ , unparseMethodDescriptor+ , mainKey+ -- * Debugging information+ , hasDebugInfo+ , classSourceFile+ , sourceLineNumberInfo+ , sourceLineNumberOrPrev+ , lookupLineStartPC+ , lookupLineMethodStartPC+ , localVariableEntries+ , lookupLocalVariableByIdx+ , lookupLocalVariableByName+ , ppInst+ , slashesToDots+ , cfgToDot+ ) where++import Control.Exception (assert)+import Control.Monad+import Data.Array (Array, (!), listArray)+import Data.Binary+import Data.Binary.Get+import Data.Binary.IEEE754+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.Int+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Prelude hiding(read)+import System.IO++import Language.JVM.CFG+import Language.JVM.Common++-- Version of replicate with arguments convoluted for parser.+replicateN :: (Integral b, Monad m) => m a -> b -> m [a]+replicateN fn i = sequence (replicate (fromIntegral i) fn)++showOnNewLines :: Int -> [String] -> String+showOnNewLines n [] = replicate n ' ' ++ "None"+showOnNewLines n [a] = replicate n ' ' ++ a+showOnNewLines n (a : rest) = replicate n ' ' ++ a ++ "\n" ++ showOnNewLines n rest++-- Type {{{1++parseTypeDescriptor :: String -> (Type,String)+parseTypeDescriptor ('B' : rest) = (ByteType, rest)+parseTypeDescriptor ('C' : rest) = (CharType, rest)+parseTypeDescriptor ('D' : rest) = (DoubleType, rest)+parseTypeDescriptor ('F' : rest) = (FloatType, rest)+parseTypeDescriptor ('I' : rest) = (IntType, rest)+parseTypeDescriptor ('J' : rest) = (LongType, rest)+parseTypeDescriptor ('L' : rest) = split rest []+ where split (';' : rest') result = (ClassType (reverse result), rest')+ split (ch : rest') result = split rest' (ch : result)+ split _ _ = error "internal: unable to parse type descriptor"+parseTypeDescriptor ('S' : rest) = (ShortType, rest)+parseTypeDescriptor ('Z' : rest) = (BooleanType, rest)+parseTypeDescriptor ('[' : rest) = (ArrayType tp, result)+ where (tp, result) = parseTypeDescriptor rest+parseTypeDescriptor st = error ("Unexpected type descriptor string " ++ st)++-- Visibility {{{1+data Visibility = Default | Private | Protected | Public+ deriving Eq++instance Show Visibility where+ show Default = "default"+ show Private = "private"+ show Protected = "protected"+ show Public = "public"++parseMethodDescriptor :: String -> (Maybe Type, [Type])+parseMethodDescriptor ('(' : rest) = impl rest []+ where impl ")V" types = (Nothing, reverse types)+ impl (')' : rest') types = (Just $ fst $ parseTypeDescriptor rest', reverse types)+ impl text types = let (tp, rest') = parseTypeDescriptor text+ in impl rest' (tp : types)+parseMethodDescriptor _ = error "internal: unable to parse method descriptor"++unparseMethodDescriptor :: MethodKey -> String+unparseMethodDescriptor (MethodKey _ paramTys retTy) =+ "(" ++ concatMap tyToDesc paramTys ++ ")" ++ maybe "V" tyToDesc retTy+ where+ tyToDesc (ArrayType ty) = "[" ++ tyToDesc ty+ tyToDesc BooleanType = "Z"+ tyToDesc ByteType = "B"+ tyToDesc CharType = "C"+ tyToDesc (ClassType cn) = "L" ++ cn ++ ";"+ tyToDesc DoubleType = "D"+ tyToDesc FloatType = "F"+ tyToDesc IntType = "I"+ tyToDesc LongType = "J"+ tyToDesc ShortType = "S"++-- | Returns method key with the given name and descriptor.+makeMethodKey :: String -- ^ Method name+ -> String -- ^ Method descriptor+ -> MethodKey+makeMethodKey name descriptor = MethodKey name parameters returnType + where (returnType, parameters) = parseMethodDescriptor descriptor++mainKey :: MethodKey+mainKey = makeMethodKey "main" "([Ljava/lang/String;)V"++-- ConstantPool {{{1++data ConstantPoolInfo+ = ConstantClass Word16+ | FieldRef Word16 Word16+ | MethodRef Word16 Word16+ | InterfaceMethodRef Word16 Word16+ | ConstantString Word16+ | ConstantInteger Int32+ | ConstantFloat Float+ | ConstantLong Int64+ | ConstantDouble Double+ | NameAndType Word16 Word16+ | Utf8 String+ -- | Used for gaps after Long and double entries+ | Phantom+ deriving (Show)++-- Parses array of bytes from Java string+getJavaString :: [Word8] -> String+getJavaString [] = []+getJavaString (x : rest)+ | (x .&. 0x80) == 0 = chr (fromIntegral x) : getJavaString rest+getJavaString (x : y : rest)+ | (x .&. 0xE0) == 0xC0 && ((y .&. 0xC0) == 0x80)+ = chr i : getJavaString rest+ where i = (fromIntegral x .&. 0x1F) `shift` 6 + (fromIntegral y .&. 0x3F)+getJavaString (x : y : z : rest)+ | (x .&. 0xF0) == 0xE0 && ((y .&. 0xC0) == 0x80) && ((z .&. 0xC0) == 0x80)+ = chr i : getJavaString rest+ where i = ((fromIntegral x .&. 0x0F) `shift` 12+ + (fromIntegral y .&. 0x3F) `shift` 6+ + (fromIntegral z .&. 0x3F))+getJavaString _ = error "internal: unable to parse byte array for Java string"++getConstantPoolInfo :: Get [ConstantPoolInfo]+getConstantPoolInfo = do+ tag <- getWord8+ case tag of+ -- CONSTANT_Utf8+ 1 -> do bytes <- replicateN getWord8 =<< getWord16be+ return [Utf8 $ getJavaString bytes]+ ---- CONSTANT_Integer+ 3 -> do val <- get+ return [ConstantInteger val]+ ---- CONSTANT_Float+ 4 -> do v <- getFloat32be+ return [ConstantFloat v]+ ---- CONSTANT_Long+ 5 -> do val <- get+ return [Phantom, ConstantLong val]+ ---- CONSTANT_Double+ 6 -> do val <- getFloat64be+ return [Phantom, ConstantDouble val]+ ---- CONSTANT_Class+ 7 -> do index <- getWord16be+ return [ConstantClass index]+ ---- CONSTANT_String+ 8 -> do index <- getWord16be+ return [ConstantString index]+ ---- CONSTANT_Fieldref+ 9 -> do classIndex <- getWord16be+ nameTypeIndex <- getWord16be+ return [FieldRef classIndex nameTypeIndex]+ ---- CONSTANT_Methodref+ 10 -> do classIndex <- getWord16be+ nameTypeIndex <- getWord16be+ return [MethodRef classIndex nameTypeIndex]+ ---- CONSTANT_InterfaceMethodref+ 11 -> do classIndex <- getWord16be+ nameTypeIndex <- getWord16be+ return [InterfaceMethodRef classIndex nameTypeIndex]+ ---- CONSTANT_NameAndType+ 12 -> do classIndex <- getWord16be+ nameTypeIndex <- getWord16be+ return [NameAndType classIndex nameTypeIndex]+ _ -> do position <- bytesRead+ error ("Unexpected constant " ++ show tag ++ " at position " ++ show position)++type ConstantPoolIndex = Word16+type ConstantPool = Array ConstantPoolIndex ConstantPoolInfo++-- Get monad that extract ConstantPool from input.+getConstantPool :: Get ConstantPool+getConstantPool = do+ poolCount <- getWord16be+ list <- parseList (poolCount - 1) []+ return $ listArray (1, poolCount - 1) list+ where parseList 0 result = return $ reverse result+ parseList n result = do+ info <- getConstantPoolInfo+ parseList (n - fromIntegral (length info)) (info ++ result)++-- | Returns string at given index in constant pool or raises error+-- | if constant pool index is not a Utf8 string.+poolUtf8 :: ConstantPool -> ConstantPoolIndex -> String+poolUtf8 cp i =+ case cp ! i of+ Utf8 s -> s+ v -> error $ "Index " ++ show i ++ " has value " ++ show v ++ " when string expected."++-- | Returns value at given index in constant pool or raises error+-- | if constant pool index is not a value.+poolValue :: ConstantPool -> ConstantPoolIndex -> ConstantPoolValue+poolValue cp i =+ case cp ! i of+ ConstantClass j -> ClassRef (cp `poolUtf8` j)+ ConstantDouble v -> Double v+ ConstantFloat v -> Float v+ ConstantInteger v -> Integer v+ ConstantLong v -> Long v+ ConstantString j -> String (cp `poolUtf8` j)+ v -> error ("Index " ++ show i ++ " has unexpected value " ++ show v+ ++ " when a constant was expected.")++poolClassType :: ConstantPool -> ConstantPoolIndex -> Type+poolClassType cp i+ = case cp ! i of+ ConstantClass j ->+ let typeName = poolUtf8 cp j+ in if head typeName == '['+ then fst (parseTypeDescriptor typeName)+ else ClassType typeName+ _ -> error ("Index " ++ show i ++ " is not a class reference.")++poolNameAndType :: ConstantPool -> ConstantPoolIndex -> (String, String)+poolNameAndType cp i+ = case cp ! i of+ NameAndType nameIndex typeIndex ->+ (poolUtf8 cp nameIndex, poolUtf8 cp typeIndex)+ _ -> error ("Index " ++ show i ++ " is not a name and type reference.")++-- | Returns tuple containing field class, name, and type at given index.+poolFieldRef :: ConstantPool -> ConstantPoolIndex -> FieldId+poolFieldRef cp i+ = case cp ! i of+ FieldRef classIndex ntIndex ->+ let (name, fldDescriptor) = poolNameAndType cp ntIndex+ (fldType, []) = parseTypeDescriptor fldDescriptor+ ClassType cName = poolClassType cp classIndex+ in FieldId cName name fldType+ _ -> error ("Index " ++ show i ++ " is not a field reference.")++poolInterfaceMethodRef :: ConstantPool -> ConstantPoolIndex -> (Type, MethodKey)+poolInterfaceMethodRef cp i+ = case cp ! i of+ InterfaceMethodRef classIndex ntIndex ->+ let (name, fieldDescriptor) = poolNameAndType cp ntIndex+ interfaceType = poolClassType cp classIndex+ in (interfaceType, makeMethodKey name fieldDescriptor)+ _ -> error ("Index " ++ show i ++ " is not an interface method reference.")++poolMethodRef :: ConstantPool -> ConstantPoolIndex -> (Type, MethodKey)+poolMethodRef cp i+ = case cp ! i of+ MethodRef classIndex ntIndex ->+ let (name, fieldDescriptor) = poolNameAndType cp ntIndex+ classType = poolClassType cp classIndex+ in (classType, makeMethodKey name fieldDescriptor)+ _ -> error ("Index " ++ show i ++ " is not a method reference.")++_uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d+_uncurry3 fn (a,b,c) = fn a b c++-- (getInstruction cp addr) returns a parser for the instruction+-- at the address addr.+getInstruction :: ConstantPool -> PC -> Get Instruction+getInstruction cp address = do+ op <- getWord8+ case op of+ 0x00 -> return Nop+ 0x01 -> return Aconst_null+ 0x02 -> return $ Ldc $ Integer (-1)+ 0x03 -> return $ Ldc $ Integer 0+ 0x04 -> return $ Ldc $ Integer 1+ 0x05 -> return $ Ldc $ Integer 2+ 0x06 -> return $ Ldc $ Integer 3+ 0x07 -> return $ Ldc $ Integer 4+ 0x08 -> return $ Ldc $ Integer 5+ 0x09 -> return $ Ldc $ Long 0+ 0x0A -> return $ Ldc $ Long 1+ 0x0B -> return $ Ldc $ Float 0.0+ 0x0C -> return $ Ldc $ Float 1.0+ 0x0D -> return $ Ldc $ Float 2.0+ 0x0E -> return $ Ldc $ Double 0.0+ 0x0F -> return $ Ldc $ Double 1.0+ 0x10 -> liftM (Ldc . Integer . fromIntegral) (get :: Get Int8)+ 0x11 -> liftM (Ldc . Integer . fromIntegral) (get :: Get Int16)+ 0x12 -> liftM (Ldc . poolValue cp . fromIntegral) getWord8+ 0x13 -> liftM (Ldc . poolValue cp) getWord16be+ 0x14 -> liftM (Ldc . poolValue cp) getWord16be+ 0x15 -> liftM (Iload . fromIntegral) getWord8+ 0x16 -> liftM (Lload . fromIntegral) getWord8+ 0x17 -> liftM (Fload . fromIntegral) getWord8+ 0x18 -> liftM (Dload . fromIntegral) getWord8+ 0x19 -> liftM (Aload . fromIntegral) getWord8+ 0x1A -> return (Iload 0)+ 0x1B -> return (Iload 1)+ 0x1C -> return (Iload 2)+ 0x1D -> return (Iload 3)+ 0x1E -> return (Lload 0)+ 0x1F -> return (Lload 1)+ 0x20 -> return (Lload 2)+ 0x21 -> return (Lload 3)+ 0x22 -> return (Fload 0)+ 0x23 -> return (Fload 1)+ 0x24 -> return (Fload 2)+ 0x25 -> return (Fload 3)+ 0x26 -> return (Dload 0)+ 0x27 -> return (Dload 1)+ 0x28 -> return (Dload 2)+ 0x29 -> return (Dload 3)+ 0x2A -> return (Aload 0)+ 0x2B -> return (Aload 1)+ 0x2C -> return (Aload 2)+ 0x2D -> return (Aload 3)+ 0x2E -> return Iaload+ 0x2F -> return Laload+ 0x30 -> return Faload+ 0x31 -> return Daload+ 0x32 -> return Aaload+ 0x33 -> return Baload+ 0x34 -> return Caload+ 0x35 -> return Saload+ 0x36 -> liftM (Istore . fromIntegral) getWord8+ 0x37 -> liftM (Lstore . fromIntegral) getWord8+ 0x38 -> liftM (Fstore . fromIntegral) getWord8+ 0x39 -> liftM (Dstore . fromIntegral) getWord8+ 0x3A -> liftM (Astore . fromIntegral) getWord8+ 0x3B -> return (Istore 0)+ 0x3C -> return (Istore 1)+ 0x3D -> return (Istore 2)+ 0x3E -> return (Istore 3)+ 0x3F -> return (Lstore 0)+ 0x40 -> return (Lstore 1)+ 0x41 -> return (Lstore 2)+ 0x42 -> return (Lstore 3)+ 0x43 -> return (Fstore 0)+ 0x44 -> return (Fstore 1)+ 0x45 -> return (Fstore 2)+ 0x46 -> return (Fstore 3)+ 0x47 -> return (Dstore 0)+ 0x48 -> return (Dstore 1)+ 0x49 -> return (Dstore 2)+ 0x4A -> return (Dstore 3)+ 0x4B -> return (Astore 0)+ 0x4C -> return (Astore 1)+ 0x4D -> return (Astore 2)+ 0x4E -> return (Astore 3)+ 0x4F -> return Iastore+ 0x50 -> return Lastore+ 0x51 -> return Fastore+ 0x52 -> return Dastore+ 0x53 -> return Aastore+ 0x54 -> return Bastore+ 0x55 -> return Castore+ 0x56 -> return Sastore+ 0x57 -> return Pop+ 0x58 -> return Pop2+ 0x59 -> return Dup+ 0x5A -> return Dup_x1+ 0x5B -> return Dup_x2+ 0x5C -> return Dup2+ 0x5D -> return Dup2_x1+ 0x5E -> return Dup2_x2+ 0x5F -> return Swap+ 0x60 -> return Iadd+ 0x61 -> return Ladd+ 0x62 -> return Fadd+ 0x63 -> return Dadd+ 0x64 -> return Isub+ 0x65 -> return Lsub+ 0x66 -> return Fsub+ 0x67 -> return Dsub+ 0x68 -> return Imul+ 0x69 -> return Lmul+ 0x6A -> return Fmul+ 0x6B -> return Dmul+ 0x6C -> return Idiv+ 0x6D -> return Ldiv+ 0x6E -> return Fdiv+ 0x6F -> return Ddiv+ 0x70 -> return Irem+ 0x71 -> return Lrem+ 0x72 -> return Frem+ 0x73 -> return Drem+ 0x74 -> return Ineg+ 0x75 -> return Lneg+ 0x76 -> return Fneg+ 0x77 -> return Dneg+ 0x78 -> return Ishl+ 0x79 -> return Lshl+ 0x7A -> return Ishr+ 0x7B -> return Lshr+ 0x7C -> return Iushr+ 0x7D -> return Lushr+ 0x7E -> return Iand+ 0x7F -> return Land+ 0x80 -> return Ior+ 0x81 -> return Lor+ 0x82 -> return Ixor+ 0x83 -> return Lxor+ 0x84 -> do+ index <- getWord8+ constant <- get :: Get Int8+ return (Iinc (fromIntegral index) (fromIntegral constant))+ 0x85 -> return I2l+ 0x86 -> return I2f+ 0x87 -> return I2d+ 0x88 -> return L2i+ 0x89 -> return L2f+ 0x8A -> return L2d+ 0x8B -> return F2i+ 0x8C -> return F2l+ 0x8D -> return F2d+ 0x8E -> return D2i+ 0x8F -> return D2l+ 0x90 -> return D2f+ 0x91 -> return I2b+ 0x92 -> return I2c+ 0x93 -> return I2s+ 0x94 -> return Lcmp+ 0x95 -> return Fcmpl+ 0x96 -> return Fcmpg+ 0x97 -> return Dcmpl+ 0x98 -> return Dcmpg+ 0x99 -> return . Ifeq . (address +) . fromIntegral =<< (get :: Get Int16)+ 0x9A -> return . Ifne . (address +) . fromIntegral =<< (get :: Get Int16)+ 0x9B -> return . Iflt . (address +) . fromIntegral =<< (get :: Get Int16)+ 0x9C -> return . Ifge . (address +) . fromIntegral =<< (get :: Get Int16)+ 0x9D -> return . Ifgt . (address +) . fromIntegral =<< (get :: Get Int16)+ 0x9E -> return . Ifle . (address +) . fromIntegral =<< (get :: Get Int16)+ 0x9F -> return . If_icmpeq . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA0 -> return . If_icmpne . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA1 -> return . If_icmplt . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA2 -> return . If_icmpge . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA3 -> return . If_icmpgt . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA4 -> return . If_icmple . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA5 -> return . If_acmpeq . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA6 -> return . If_acmpne . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA7 -> return . Goto . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA8 -> return . Jsr . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xA9 -> liftM (Ret . fromIntegral) getWord8+ 0xAA -> do+ read <- bytesRead+ skip $ fromIntegral $ (4 - read `mod` 4) `mod` 4+ defaultBranch <- return . (address +) . fromIntegral =<< (get :: Get Int32)+ low <- get :: Get Int32+ high <- get :: Get Int32+ offsets <- replicateN+ (return . (address +) . fromIntegral =<< (get :: Get Int32))+ (high - low + 1)+ return $ Tableswitch defaultBranch low high offsets+ 0xAB -> do+ read <- bytesRead+ skip (fromIntegral ((4 - read `mod` 4) `mod` 4))+ defaultBranch <- get :: Get Int32+ count <- get :: Get Int32+ pairs <- replicateM (fromIntegral count) $ do+ v <- get :: Get Int32+ o <- get :: Get Int32+ return (v, ((address +) . fromIntegral) o)+ return $ Lookupswitch (address + fromIntegral defaultBranch) pairs+ 0xAC -> return Ireturn+ 0xAD -> return Lreturn+ 0xAE -> return Freturn+ 0xAF -> return Dreturn+ 0xB0 -> return Areturn+ 0xB1 -> return Return+ 0xB2 -> return . Getstatic . poolFieldRef cp =<< getWord16be+ 0xB3 -> return . Putstatic . poolFieldRef cp =<< getWord16be+ 0xB4 -> return . Getfield . poolFieldRef cp =<< getWord16be+ 0xB5 -> return . Putfield . poolFieldRef cp =<< getWord16be+ 0xB6 -> do index <- getWord16be+ let (classType, key) = poolMethodRef cp index+ return $ Invokevirtual classType key+ 0xB7 -> do index <- getWord16be+ let (classType, key) = poolMethodRef cp index+ return $ Invokespecial classType key+ 0xB8 -> do index <- getWord16be+ let (ClassType cName, key) = poolMethodRef cp index+ in return $ Invokestatic cName key+ 0xB9 -> do index <- getWord16be+ _ <- getWord8+ _ <- getWord8+ let (ClassType cName, key) = poolInterfaceMethodRef cp index+ in return $ Invokeinterface cName key+ 0xBB -> do+ index <- getWord16be+ case (poolClassType cp index) of+ ClassType name -> return (New name)+ _ -> error "internal: unexpected pool class type"+ 0xBC -> do+ typeCode <- getWord8+ (return . Newarray . ArrayType)+ (case typeCode of+ 4 -> BooleanType+ 5 -> CharType+ 6 -> FloatType+ 7 -> DoubleType+ 8 -> ByteType+ 9 -> ShortType+ 10 -> IntType+ 11 -> LongType+ _ -> error "internal: invalid type code encountered"+ )+ 0xBD -> return . Newarray . ArrayType . poolClassType cp =<< get+ 0xBE -> return Arraylength+ 0xBF -> return Athrow+ 0xC0 -> return . Checkcast . poolClassType cp =<< get+ 0xC1 -> return . Instanceof . poolClassType cp =<< get+ 0xC2 -> return Monitorenter+ 0xC3 -> return Monitorexit+ -- Wide instruction+ 0xC4 -> do+ embeddedOp <- getWord8+ case embeddedOp of+ 0x15 -> liftM Iload getWord16be+ 0x16 -> liftM Lload getWord16be+ 0x17 -> liftM Fload getWord16be+ 0x18 -> liftM Dload getWord16be+ 0x19 -> liftM Aload getWord16be+ 0x36 -> liftM Istore getWord16be+ 0x37 -> liftM Lstore getWord16be+ 0x38 -> liftM Fstore getWord16be+ 0x39 -> liftM Dstore getWord16be+ 0x3A -> liftM Astore getWord16be+ 0x84 -> liftM2 Iinc getWord16be (get :: Get Int16)+ 0xA9 -> liftM Ret getWord16be+ _ -> do+ position <- bytesRead+ error ("Unexpected wide op " ++ (show op) ++ " at position " ++ show (position - 2))+ 0xC5 -> do+ classIndex <- getWord16be+ dimensions <- getWord8+ return (Multianewarray (poolClassType cp classIndex) dimensions)+ 0xC6 -> return . Ifnull . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xC7 -> return . Ifnonnull . (address +) . fromIntegral =<< (get :: Get Int16)+ 0xC8 -> return . Goto . (address +) . fromIntegral =<< (get :: Get Int32)+ 0xC9 -> return . Jsr . (address +) . fromIntegral =<< (get :: Get Int32)+ _ -> do+ position <- bytesRead+ error ("Unexpected op " ++ (show op) ++ " at position " ++ show (position - 1))++-- Attributes {{{1++-- | An uninterpreted user defined attribute in the class file.+data Attribute = Attribute {+ attributeName :: String+ , attributeData :: B.ByteString+ } deriving (Eq,Show)++-- Returns getter that parses attributes from stream and buckets them based on name.+splitAttributes :: ConstantPool -> [String] -> Get ([[L.ByteString]], [Attribute])+splitAttributes cp names = do+ count <- getWord16be+ impl count (replicate (length names) []) []+ where -- (appendAt list-of-lists index val) adds val to front of list at+ -- index i in list-of-lists+ appendAt (l : rest) 0 a = (l ++ [a]) : rest+ appendAt (first : rest) n a = first : appendAt rest (n - 1) a+ appendAt [] _ _ = error "internal: appendAt expects non-empty list"+ -- Parse values+ impl 0 values rest = return (values, reverse rest)+ impl n values rest = do+ nameIndex <- getWord16be+ len <- getWord32be+ let name = (poolUtf8 cp nameIndex)+ in case elemIndex name names of+ Just i -> do+ bytes <- getLazyByteString (fromIntegral len)+ impl (n-1) (appendAt values i bytes) rest+ Nothing -> do+ bytes <- getByteString (fromIntegral len)+ impl (n-1) values (Attribute name bytes : rest)++-- Field declarations {{{1+-- | A class instance of static field+data Field = Field {+ -- | Returns name of field.+ fieldName :: String+ -- | Returns type of field.+ , fieldType :: Type+ -- | Returns visibility of field.+ , fieldVisibility :: Visibility+ -- | Returns true if field is static.+ , fieldIsStatic :: Bool+ -- | Returns true if field is final.+ , fieldIsFinal :: Bool+ -- | Returns true if field is volatile.+ , fieldIsVolatile :: Bool+ -- | Returns true if field is transient.+ , fieldIsTransient :: Bool+ -- | Returns initial value of field or Nothing if not assigned.+ --+ -- Only static fields may have a constant value.+ , fieldConstantValue :: Maybe ConstantPoolValue+ -- | Returns true if field is synthetic.+ , fieldIsSynthetic :: Bool+ -- | Returns true if field is deprecated.+ , fieldIsDeprecated :: Bool+ -- | Returns true if field is transient.+ , fieldIsEnum :: Bool+ , fieldSignature :: Maybe String+ , fieldAttributes :: [Attribute]+ } deriving (Show)++-- instance Show Field where+-- show (Field (FieldKey name tp)+-- visibility+-- isStatic+-- isFinal+-- isVolatile+-- isTransient+-- constantValue+-- isSynthetic+-- isDeprecated+-- isEnum+-- signature+-- attrs)+-- = show visibility ++ " "+-- ++ (if isStatic then "static " else "")+-- ++ (if isFinal then "final " else "")+-- ++ (if isVolatile then "volatile " else "")+-- ++ (if isTransient then "transient " else "")+-- ++ show tp ++ " "+-- ++ name+-- ++ case constantValue of+-- Nothing -> ""+-- Just (Long l) -> " = " ++ show l ++ " "+-- Just (Float f) -> " = " ++ show f ++ " "+-- Just (Double d) -> " = " ++ show d ++ " "+-- Just (Integer i) -> " = " ++ show i ++ " "+-- Just (String s) -> " = " ++ show s ++ " "+-- ++ (if isSynthetic then " synthetic " else "")+-- ++ (if isDeprecated then " deprecated " else "")+-- ++ show attrs++getField :: ConstantPool -> Get Field+getField cp = do+ accessFlags <- getWord16be+ name <- return . poolUtf8 cp =<< getWord16be+ fldType <- return . fst . parseTypeDescriptor . poolUtf8 cp =<< getWord16be+ ([constantValue, synthetic, deprecated, signature], userAttrs)+ <- splitAttributes cp ["ConstantValue", "Synthetic", "Deprecated", "Signature"]+ return $ Field name+ fldType+ -- Visibility+ (case accessFlags .&. 0x7 of+ 0x0 -> Default+ 0x1 -> Public+ 0x2 -> Private+ 0x4 -> Protected+ flags -> error $ "Unexpected flags " ++ show flags)+ -- Static+ ((accessFlags .&. 0x0008) /= 0)+ -- Final+ ((accessFlags .&. 0x0010) /= 0)+ -- Volatile+ ((accessFlags .&. 0x0040) /= 0)+ -- Transient+ ((accessFlags .&. 0x0080) /= 0)+ -- Constant Value+ (case constantValue of+ [bytes] -> Just $ poolValue cp $ runGet getWord16be bytes+ [] -> Nothing+ _ -> error "internal: unexpected constant value form"+ )+ -- Check for synthetic bit in flags and buffer+ ((accessFlags .&. 0x1000) /= 0 || (not (null synthetic)))+ -- Deprecated flag+ (not (null deprecated))+ -- Check for enum bit in flags+ ((accessFlags .&. 0x4000) /= 0)+ -- Signature+ (case signature of+ [bytes] ->+ Just $ poolUtf8 cp $ runGet getWord16be bytes+ [] -> Nothing+ _ -> error "internal: unexpected signature form"+ )+ userAttrs++-- Method declarations {{{1+-- ExceptionTableEntry {{{2++getExceptionTableEntry :: ConstantPool -> Get ExceptionTableEntry+getExceptionTableEntry cp = do+ startPc' <- getWord16be+ endPc' <- getWord16be+ handlerPc' <- getWord16be+ catchType' <- getWord16be+ return (ExceptionTableEntry startPc'+ endPc'+ handlerPc'+ (if catchType' == 0+ then Nothing+ else Just (poolClassType cp catchType')))++-- InstructionStream {{{2++-- Run Get Monad until end of string is reached and return list of results.+getInstructions :: ConstantPool -> PC -> Get InstructionStream+getInstructions cp count = do+ read <- bytesRead+ impl 0 read []+ where impl pos prevRead result = do+ if pos == (fromIntegral count)+ then return (listArray (0, count - 1) (reverse result))+ else do+ inst <- getInstruction cp pos+ newRead <- bytesRead+ let dist = fromIntegral (newRead - prevRead)+ padding = replicate (fromIntegral (dist - 1)) Nothing+ in impl (pos + dist) newRead (padding ++ (Just inst : result))++-- Returns valid program counters in ascending order.+{-+getValidPcs :: InstructionStream -> [PC]+getValidPcs = map fst . filter (isJust . snd) . assocs+ where isJust Nothing = False+ isJust _ = True+-}++-- LineNumberTable {{{2+getLineNumberTableEntries :: Get [(PC,Word16)]+getLineNumberTableEntries = do+ tableLength <- getWord16be+ replicateM (fromIntegral tableLength)+ (do startPc' <- getWord16be+ lineNumber <- getWord16be+ return (startPc', lineNumber))+++data LineNumberTable = LNT {+ pcLineMap :: Map PC Word16+ , linePCMap :: Map Word16 PC+ } deriving (Eq,Show)++parseLineNumberTable :: [L.ByteString] -> LineNumberTable+parseLineNumberTable buffers =+ let l = concatMap (runGet getLineNumberTableEntries) buffers+ in LNT { pcLineMap = Map.fromList l+ , linePCMap = Map.fromListWith min [ (ln,pc) | (pc,ln) <- l ]+ }++-- LocalVariableTableEntry {{{2+data LocalVariableTableEntry+ = LocalVariableTableEntry+ { localStart :: PC -- Start PC+ , localExtent :: PC -- length+ , localName :: String -- Name+ , localType :: Type -- Type of local variable+ , localIdx :: LocalVariableIndex -- Index of local variable+ }+ deriving (Eq,Show)++-- Maps pc and local variable index to name and type of variable in source.+type LocalVariableTable = [LocalVariableTableEntry]++getLocalVariableTableEntries :: ConstantPool -> Get [LocalVariableTableEntry]+getLocalVariableTableEntries cp = do+ tableLength <- getWord16be+ replicateM (fromIntegral tableLength)+ (do startPc' <- getWord16be+ len <- getWord16be+ nameIndex <- getWord16be+ descriptorIndex <- getWord16be+ index <- getWord16be+ return $ LocalVariableTableEntry+ startPc'+ len+ (poolUtf8 cp nameIndex)+ (fst $ parseTypeDescriptor $ poolUtf8 cp descriptorIndex)+ index)++parseLocalVariableTable :: ConstantPool -> [L.ByteString] -> [LocalVariableTableEntry]+parseLocalVariableTable cp buffers =+ (concat $ map (runGet $ getLocalVariableTableEntries cp) buffers)++-- {{{2 Method body+data MethodBody+ = Code Word16 -- maxStack+ Word16 -- maxLocals+ CFG+ [ExceptionTableEntry] -- exception table+ LineNumberTable -- Line number table entries (empty if information not provided)+ LocalVariableTable -- Local variable table entries (optional)+ [Attribute] -- Code attributes+ | AbstractMethod+ | NativeMethod+ deriving (Eq,Show)++getCode :: ConstantPool -> Get MethodBody+getCode cp = do+ maxStack <- getWord16be+ maxLocals <- getWord16be+ codeLength <- getWord32be+ instructions <- getInstructions cp (fromIntegral codeLength)+ exceptionTable <- getWord16be >>= replicateN (getExceptionTableEntry cp)+ ([lineNumberTables, localVariableTables], userAttrs)+ <- splitAttributes cp ["LineNumberTable", "LocalVariableTable"]+ return $ Code maxStack+ maxLocals+ (buildCFG exceptionTable instructions)+ exceptionTable+ (parseLineNumberTable lineNumberTables)+ (parseLocalVariableTable cp localVariableTables)+ userAttrs++-- {{{2 Method definitions+data Method = Method {+ methodKey :: MethodKey+ , _visibility :: Visibility+ , methodIsStatic :: Bool+ , _methodIsFinal :: Bool+ , _isSynchronized :: Bool+ , _isStrictFp :: Bool+ , methodBody :: MethodBody+ , _exceptions :: Maybe [Type]+ , _isSynthetic :: Bool+ , _isDeprecated :: Bool+ , _attributes :: [Attribute]+ } deriving (Eq,Show)++instance Ord Method where+ compare m1 m2 = compare (methodKey m1) (methodKey m2)++-- instance Show Method where+-- show (Method (MethodKey name returnType parameterTypes)+-- visibility+-- isStatic+-- isFinal+-- isSynchronized+-- isStrictFp+-- body+-- exceptions+-- isSynthetic+-- isDeprecated+-- attrs)+-- = show visibility ++ " "+-- ++ (if isStatic then "static" else "")+-- ++ (if isFinal then "final " else "")+-- ++ (if isSynchronized then "synchronized " else "")+-- ++ (case body of+-- AbstractMethod -> "abstract "+-- NativeMethod -> "native "+-- _ -> "")+-- ++ (if isStrictFp then "strict " else "")+-- ++ case returnType of+-- Just tp -> (show tp)+-- Nothing -> "void"+-- ++ " " ++ name+-- ++ "(" ++ showCommaSeparatedList parameterTypes ++ ")"+-- ++ show attrs ++ "\n"+-- ++ (if isSynthetic then " synthetic\n" else "")+-- ++ (if isDeprecated then " deprecated\n" else "")+-- ++ case body of+-- Code maxStack maxLocals is exceptions lineNumbers _ codeAttrs ->+-- " Max Stack: " ++ show maxStack+-- ++ " Max Locals: " ++ show maxLocals ++ "\n"+-- ++ (showOnNewLines 4+-- [ show i ++ ": " ++ show inst+-- ++ (case Map.lookup i lineNumbers of+-- Just l -> "(line " ++ show l ++ ")"+-- Nothing -> "")+-- | (i, Just inst) <- assocs is ])+-- ++ if null exceptions+-- then ""+-- else "\n Exceptions: " ++ show exceptions+-- ++ if null codeAttrs+-- then ""+-- else "\n Attributes: " ++ show codeAttrs+-- _ -> ""++getExceptions :: ConstantPool -> Get [Type]+getExceptions cp = do+ exceptionCount <- getWord16be+ replicateN (getWord16be >>= return . poolClassType cp) exceptionCount++getMethod :: ConstantPool -> Get Method+getMethod cp = do+ accessFlags <- getWord16be+ name <- getWord16be >>= return . (poolUtf8 cp)+ (returnType, parameterTypes) <- getWord16be >>= return . parseMethodDescriptor . (poolUtf8 cp)+ ([codeVal, exceptionsVal, syntheticVal, deprecatedVal], userAttrs)+ <- splitAttributes cp ["Code", "Exceptions", "Synthetic", "Deprecated"]+ let isStatic' = (accessFlags .&. 0x008) /= 0+ isFinal = (accessFlags .&. 0x010) /= 0+ isSynchronized' = (accessFlags .&. 0x020) /= 0+ isAbstract = (accessFlags .&. 0x400) /= 0+ isStrictFp' = (accessFlags .&. 0x800) /= 0+ in return $+ Method (MethodKey name parameterTypes returnType)+ -- Visibility+ (case accessFlags .&. 0x7 of+ 0x0 -> Default+ 0x1 -> Public+ 0x2 -> Private+ 0x4 -> Protected+ flags -> error $ "Unexpected flags " ++ show flags)+ isStatic'+ isFinal+ isSynchronized'+ isStrictFp'+ (if ((accessFlags .&. 0x100) /= 0)+ then NativeMethod+ else if isAbstract+ then AbstractMethod+ else case codeVal of+ [bytes] -> runGet (getCode cp) bytes+ _ -> error "Could not find code attribute")+ (case exceptionsVal of+ [bytes] -> Just (runGet (getExceptions cp) bytes)+ [] -> Nothing+ _ -> error "internal: unexpected expectionsVal form"+ )+ (not $ null syntheticVal)+ (not $ null deprecatedVal)+ userAttrs++methodIsNative :: Method -> Bool+methodIsNative m =+ case methodBody m of+ NativeMethod -> True+ _ -> False++-- | Returns true if method is abstract.+methodIsAbstract :: Method -> Bool+methodIsAbstract m =+ case methodBody m of+ AbstractMethod -> True+ _ -> False++-- | Returns name of method+methodName :: Method -> String+methodName = methodKeyName . methodKey++-- | Return parameter types for method.+methodParameterTypes :: Method -> [Type]+methodParameterTypes = methodKeyParameterTypes . methodKey++-- | Returns the local variable index that the parameter is stored in when+-- the method is invoked.+localIndexOfParameter :: Method -> Int -> LocalVariableIndex+localIndexOfParameter m i = assert (0 <= i && i < length params) $ offsets !! idx+ where params = methodParameterTypes m+ -- Index after accounting for this.+ idx = if methodIsStatic m then i else i + 1+ slotWidth DoubleType = 2+ slotWidth LongType = 2+ slotWidth _ = 1+ offsets = (0:) . snd $ foldl f (0,[]) (map slotWidth params)+ where+ f (n,acc) x = (n+x, acc ++ [n+1])++-- | Return parameter types for method.+methodReturnType :: Method -> Maybe Type+methodReturnType = methodKeyReturnType . methodKey++-- (lookupInstruction method pc) returns instruction at pc in method.+lookupInstruction :: Method -> PC -> Instruction+lookupInstruction method pc =+ case methodBody method of+ Code _ _ cfg _ _ _ _ ->+ case (cfgInstByPC cfg pc) of+ Just i -> i+ Nothing -> error "internal: failed to index inst stream"+ _ -> error ("Method " ++ show method ++ " has no body")+++-- Returns pc of next instruction.+nextPc :: Method -> PC -> PC+nextPc method pc =+-- trace ("nextPC: method = " ++ show method) $+ case methodBody method of+ Code _ _ cfg _ _ _ _ ->+-- nextPcPrim (toInstStream cfg) pc+ case nextPC cfg pc of+ Nothing -> error "JavaParser.nextPc: no next instruction"+ Just npc -> npc+ _ -> error "internal: unexpected method body form"++-- | Returns maxinum number of local variables in method.+methodMaxLocals :: Method -> LocalVariableIndex+methodMaxLocals method =+ case methodBody method of+ Code _ c _ _ _ _ _ -> c+ _ -> error "internal: unexpected method body form"++-- | Returns true if method has debug informaiton available.+hasDebugInfo :: Method -> Bool+hasDebugInfo method =+ case methodBody method of+ Code _ _ _ _ lns lvars _ -> not (Map.null (pcLineMap lns) && null lvars)+ _ -> False++methodLineNumberTable :: Method -> Maybe LineNumberTable+methodLineNumberTable me = do+ case methodBody me of+ Code _ _ _ _ lns _ _ -> Just lns+ _ -> Nothing++sourceLineNumberInfo :: Method -> [(Word16,PC)]+sourceLineNumberInfo me =+ maybe [] (Map.toList . pcLineMap) $ methodLineNumberTable me++-- | Returns source line number of an instruction in a method at a given PC,+-- or the line number of the nearest predecessor instruction, or Nothing if+-- neither is available.+sourceLineNumberOrPrev :: Method -> PC -> Maybe Word16+sourceLineNumberOrPrev me pc =+ case methodBody me of+ Code _ _ _ _ lns _ _ ->+ case Map.splitLookup pc (pcLineMap lns) of+ (prs, Nothing, _)+ | not $ Map.null prs -> Just $ snd $ Map.findMax prs+ | otherwise -> Nothing+ (_, ln, _) -> ln+ _ -> error "internal: unexpected method body form"++-- | Returns the starting PC for the source at the given line number.+lookupLineStartPC :: Method -> Word16 -> Maybe PC+lookupLineStartPC me ln = do+ m <- methodLineNumberTable me+ Map.lookup ln (linePCMap m)++-- | Returns the enclosing method and starting PC for the source at the given line number.+lookupLineMethodStartPC :: Class -> Word16 -> Maybe (Method, PC)+lookupLineMethodStartPC cl ln =+ case results of+ (p:_) -> return p+ [] -> mzero+ where results = do+ me <- Map.elems . classMethodMap $ cl+ case lookupLineStartPC me ln of+ Just pc -> return (me, pc)+ Nothing -> mzero++localVariableEntries :: Method -> PC -> [LocalVariableTableEntry]+localVariableEntries method pc =+ case methodBody method of+ Code _ _ _ _ _ lvars _ ->+ let matches e = localStart e <= pc &&+ pc - localStart e <= localExtent e+ in filter matches lvars+ _ -> []++-- | Returns local variable entry at given PC and local variable index or+-- Nothing if no mapping is found.+lookupLocalVariableByIdx :: Method -> PC -> LocalVariableIndex+ -> Maybe LocalVariableTableEntry+lookupLocalVariableByIdx method pc i =+ find (\e -> localIdx e == i) (localVariableEntries method pc)++-- | Returns local variable entry at given PC and local variable string or+-- Nothing if no mapping is found.+lookupLocalVariableByName :: Method -> PC -> String -> Maybe LocalVariableTableEntry+lookupLocalVariableByName method pc name =+ find (\e -> localName e == name) (localVariableEntries method pc)++-- | Exception table entries for method.+methodExceptionTable :: Method -> [ExceptionTableEntry]+methodExceptionTable method =+ case methodBody method of+ Code _ _ _ table _ _ _ -> table+ _ -> error "internal: unexpected method body form"++-- Class declarations {{{1++-- | A JVM class or interface.+data Class = MkClass {+ majorVersion :: Word16+ , minorVersion :: Word16+ , constantPool :: ConstantPool+ -- | Returns true if class is public.+ , classIsPublic :: Bool+ -- | Returns true if class is final.+ , classIsFinal :: Bool+ -- | Returns true if class was annotated with the super attribute.+ , classHasSuperAttribute :: Bool+ -- | Returns true if class is an interface+ , classIsInterface :: Bool+ -- | Returns true if class is abstract.+ , classIsAbstract :: Bool+ -- | Returns name of the class+ , className :: String+ -- | Returns name of the super class of this class or Nothing if this+ -- class has no super class.+ , superClass :: Maybe String+ -- | Returns interfaces this clas implements+ , classInterfaces :: [String]+ -- | Returns fields in the class+ , classFields :: [Field]+ -- Maps method keys to method.+ , classMethodMap :: Map MethodKey Method+ -- | Returns name of source file where class was defined.+ , classSourceFile :: Maybe String+ -- | Returns user-defined attributes on class.+ , classAttributes :: [Attribute]+ } deriving (Show)++-- | Returns methods in class+classMethods :: Class -> [Method]+classMethods = Map.elems . classMethodMap++showClass :: Class -> String+showClass cl+ = "Major Version: " ++ show (majorVersion cl) ++ "\n"+ ++ "Minor Version: " ++ show (minorVersion cl) ++ "\n"+ ++ "Constant Pool:\n" ++ show (constantPool cl) ++ "\n"+ ++ (if classIsPublic cl then "public\n" else "")+ ++ (if classIsFinal cl then "final\n" else "")+ ++ (if classHasSuperAttribute cl then "super\n" else "")+ ++ (if classIsInterface cl then "interface\n" else "")+ ++ (if classIsAbstract cl then "abstract\n" else "")+ ++ "This Class: " ++ show (className cl) ++ "\n"+ ++ "Super Class: " ++ show (superClass cl) ++ "\n"+ ++ "Interfaces:\n" ++ showOnNewLines 2 (map show (classInterfaces cl)) ++ "\n"+ ++ "Fields:\n" ++ showOnNewLines 2 (map show (classFields cl)) ++ "\n"+ ++ "Methods:\n" ++ showOnNewLines 2 (map show $ classMethods cl) ++ "\n"+ ++ "Source file: " ++ show (classSourceFile cl) ++ "\n"+ ++ "Attributes:\n" ++ showOnNewLines 2 (map show $ classAttributes cl)++-- An instance of Binary to encode and decode an Exp in binary+getClass :: Get Class+getClass = do+ magic <- getWord32be+ (if magic /= 0xCAFEBABE+ then error "Unexpected magic value"+ else return ())+ minorVersion' <- getWord16be+ majorVersion' <- getWord16be+ cp <- getConstantPool+ accessFlags <- getWord16be+ thisClass <- getReferenceName cp+ superClassIndex <- getWord16be+ interfaces <- getWord16be >>= replicateN (getReferenceName cp)+ fields <- getWord16be >>= replicateN (getField cp)+ methods <- getWord16be >>= replicateN (getMethod cp)+ ([sourceFile], userAttrs) <- splitAttributes cp ["SourceFile"]+ return $ MkClass majorVersion'+ minorVersion'+ cp+ ((accessFlags .&. 0x001) /= 0)+ ((accessFlags .&. 0x010) /= 0)+ ((accessFlags .&. 0x020) /= 0)+ ((accessFlags .&. 0x200) /= 0)+ ((accessFlags .&. 0x400) /= 0)+ thisClass+ (if superClassIndex == 0+ then Nothing+ else+ case poolClassType cp superClassIndex of+ ClassType name -> (Just name)+ classType -> error ("Unexpected class type " ++ show classType))+ interfaces+ fields+ (Map.fromList (map (\m -> (methodKey m, m)) methods))+ -- Source file+ (case sourceFile of+ [bytes] ->+ Just $ poolUtf8 cp $ runGet getWord16be bytes+ [] -> Nothing+ _ -> error "internal: unexpected source file form"+ )+ userAttrs+ where getReferenceName cp = do+ index <- getWord16be+ case poolClassType cp index of+ ClassType name -> return name+ tp -> error ("Unexpected class type " ++ show tp)++-- | Returns method with given key in class or Nothing if no method with that+-- key is found.+lookupMethod :: Class -> MethodKey -> Maybe Method+lookupMethod javaClass key = Map.lookup key (classMethodMap javaClass)++-- | Loads class at given path.+loadClass :: FilePath -> IO Class+loadClass path = do+ handle <- openBinaryFile path ReadMode+ contents <- L.hGetContents handle+ let result = runGet getClass contents+ in result `seq` (hClose handle >> return result)++getElemTy :: Type -> Type+getElemTy (ArrayType t) = aux t+ where aux (ArrayType t') = aux t'+ aux t' = t'+getElemTy _ = error "getArrElemTy given non-array type"