diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/jvm-parser.cabal b/jvm-parser.cabal new file mode 100644 --- /dev/null +++ b/jvm-parser.cabal @@ -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 diff --git a/src/Language/JVM/CFG.hs b/src/Language/JVM/CFG.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/CFG.hs @@ -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] diff --git a/src/Language/JVM/Common.hs b/src/Language/JVM/Common.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/Common.hs @@ -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 diff --git a/src/Language/JVM/JarReader.hs b/src/Language/JVM/JarReader.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/JarReader.hs @@ -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: + +-} +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" diff --git a/src/Language/JVM/Parser.hs b/src/Language/JVM/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/JVM/Parser.hs @@ -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"