--- /dev/null
+module Frontend where
+
+import Data.Int
+import Data.Word
+import Control.Monad.State
+import Data.Maybe
+import Data.List
+
+import JVM.ClassFile
+import JVM.Converter
+import JVM.Dump
+import JVM.Assembler
+
+import qualified JVM.Assembler as J
+import qualified Data.Heap as H
+import qualified Data.ByteString.Lazy as B
+import qualified Data.Map as M
+
+
+import Debug.Trace
+
+import Graph
+
+{- Thoughs on types and representations
+ - We start from constructing a CFG. What do we need here
+ - ** Fast traversal which is aware of cycles
+ - ** Fast successor, do we need predecessors?
+ - ** Find all paths to current node (including back references)
+ - ** Generic Node type in order to write mentioned operations
+ - generically. There should be no intermediate language "lock in"
+ - i.e. adding another IR should not kill CFG code
+ - Furthermore operations like SSA construction should
+ - not affect the CFG datastructure. Nodes contents should be
+ - interchangable in a way.
+ - ** Some form of unique naming - we would like to identify blocks
+ - and check whether code should be produced for this node
+ - ** Should be Haskell idiomatic - should be composed with
+ - standard haskell infrastructure
+ - ** Convinient printing
+ -
+ - From this a inductive type should be appropriate?
+ -
+ -}
+
+
+-- Means NumberedINSruction
+type Size = Int
+type NInst = (Source, Size, J.Instruction)
+-- Putting Source and Target in data types prevents from interchanging ;-)
+data Source = Source Int deriving (Eq, Ord, Show)
+data Target = Target Int deriving (Eq, Ord, Show)
+-- Source, Target Instruction id
+type SourceTarget = (Source,Target)
+-- State type for findContinuations
+type ContState = ([SourceTarget], H.MinPrioHeap Target Source)
+
+data Block = BB [NInst] deriving (Show)
+type CFG = G Block
+data BlockID = Id Int deriving (Show,Ord,Eq)
+
+type IndirectCFG = [([NInst],[Int],BlockID)]
+
+data FinalBlock = FinalBlock BlockID [NInst] deriving (Show)
+
+instance Eq FinalBlock where
+ FinalBlock (Id x) _ == FinalBlock (Id y) _ = x == y
+
+instance Ord FinalBlock where
+ FinalBlock (Id x) _ <= FinalBlock (Id y) _ = x <= y
+
+less :: Target -> Source -> Bool
+less (Target t) (Source s) = t < s
+
+addW16Signed :: Int -> Word16 -> Int
+addW16Signed i w16 = i + fromIntegral s16
+ where s16 = fromIntegral w16 :: Int16
+
+getInstOffsets :: [J.Instruction] -> [Int]
+getInstOffsets = map (\i -> fromIntegral $ B.length $ J.encodeInstructions [i])
+
+sumSeries'':: [Int] -> [Int]
+sumSeries'' = reverse . snd . foldl (\(s,xs) x -> (s+x,s : xs)) (0,[])
+
+splitBlocksBackRef :: [NInst] -> [Int]
+splitBlocksBackRef = concatMap checkSplit
+ where checkSplit inst = case inst of
+ (Source s, size, IF_ICMP _ t) -> []
+ (Source s, size, GOTO t) -> [addW16Signed s t]
+ _ -> []
+
+
+getInstructions :: [Instruction] -> [(Source, Int, Instruction)]
+getInstructions ins = zip3 (map Source $ sumSeries'' offsets) offsets ins
+ where offsets = getInstOffsets ins
+
+
+getBranch :: NInst -> [Int]
+getBranch (Source s, size, IF_ICMP _ t) = [addW16Signed s t, s+size]
+getBranch (Source s, size, GOTO t) = [addW16Signed s t]
+getBranch _ = []
+
+-- a version of Prelude.span whereby the first element
+-- which does not hold predicate f is also included in
+-- the first list
+spanPlus :: (a -> Bool) -> [a] -> ([a], [a])
+spanPlus _ [] = ([],[])
+spanPlus f (x:xs) = if f x then let (b, a) = spanPlus f xs
+ in (x:b, a)
+ else ([x],xs)
+
+fromNInst :: NInst -> Int
+fromNInst (Source s,_,_) = s
+
+ifJust :: b -> Maybe a -> [b]
+ifJust _ Nothing = []
+ifJust a (Just _) = [a]
+
+splitBlocks :: [Int] -> [NInst] -> IndirectCFG
+splitBlocks _ [] = []
+splitBlocks backRefs xs = (map fst block, block >>= snd, Id id) : splitBlocks backRefs (map fst rest)
+ where getBranchAndRef ins@(Source i,w,_) =
+ (ifJust (i+w) $ find (==i+w) backRefs) ++ getBranch ins
+ branches = zip xs $ map getBranchAndRef xs
+ (block,rest) = spanPlus (null . snd) branches
+ (Source id,_,_) = fst . head $ block -- block guarantted to be non empty
+
+getTransitions :: IndirectCFG -> (M.Map BlockID [BlockID])
+getTransitions = foldr (\(_,targets,id) s -> M.insert id (map Id targets) s) M.empty
+
+-- [([NInst],[Int],BlockID)]
+getNodes :: IndirectCFG -> [(BlockID,FinalBlock)]
+getNodes = map rearrange
+ where rearrange (insts,_,id) = (id,FinalBlock id insts)
+
+
+--indirectCFGToG :: IndirectCFG -> G [NInst]
+indirectCFGToG cfg = toG packNodes (M.toList $ getTransitions cfg) (Id 0) (getNodes cfg)
+
+{- DEPRECATED -}
+
+findContinuations :: [NInst] -> State ContState ()
+findContinuations = mapM_ addCont
+
+addCont :: NInst -> State ContState ()
+addCont (s, b, IF_ICMP _ w) = do add s (addTarget s w); jmpNext s b;
+addCont (s, _, GOTO w) = add s (addTarget s w);
+addCont (s, b, _ ) = return () --jmpNext s b
+
+jmpNext :: Source -> Int -> State ContState ()
+jmpNext s@(Source i) o = add s (Target $ i + o)
+
+
+addTarget :: Source -> Word16 -> Target
+addTarget (Source s) w16 = Target $ fromIntegral result
+ where result = s16 + fromIntegral w16 :: Int16
+ s16 = fromIntegral s :: Int16
+
+
+
+addBranch :: Source -> Target -> State ContState ()
+addBranch s t = do (branches,backRefs) <- get
+ put ( (s,t) : branches, backRefs)
+
+addBackRef :: Source -> Target -> State ContState ()
+addBackRef s t = do (branches,backRefs) <- get
+ put (branches, H.insert (t,s) backRefs)
+
+add :: Source -> Target -> State ContState ()
+add s t = do addBranch s t
+ -- if back branch - also add branch to back references
+ -- for faster access later on
+ if t `less` s then do trace ("jsadf") addBackRef s t;
+ else return ()
+
+
+
+-- Context of the Method to be compiled
+type Context = ([J.Instruction],Class Resolved)
+-- Maybe a context of the Method to be compiled
+type MContext = Maybe Context
+-- The state for CFG creation
+type CFGState = (ContState, M.Map Int CFG)
+
+type NodeState = ([(Source,Target)],[(Target,Source)])
+type IndirectGraph k a = ((M.Map k a),(M.Map k [k]))
+
+
+
+
+
+minNext :: Ord t => [t] -> [t] -> ([t], [t], Maybe t)
+minNext f@(x:xs) b@(y:ys) = if x < y then (xs, b, Just x)
+ else (f, ys, Just y)
+minNext (x:xs) [] = (xs, [], Just x )
+minNext [] (y:ys) = ([], ys, Just y )
+minNext [] [] = ([], [], Nothing)
+
+unpackst ((Source s), (Target t)) = (s,t)
+unpackts ((Target t), (Source s)) = (t,s)
+
+--createNodes :: [NInst] -> ContState -> IndirectGraph Int Block
+--createNodes xs (forwardRefs, backwardRefs) = evalState (createNodes' xs) (branches, bRefs)
+-- where branches = map reverse forwardRefs
+-- bRefs = map H.toAscList backwardRefs
+
+--createNodes' ::[NInst] -> State NodeState (IndirectGraph Int Block)
+{-createNodes' xs = do (st,ts) <- get
+ case (st,ts) of
+ -- there are back refs and forward refs
+ ((s,t):st', (t',s'):ts')
+ -> if t' `less` s
+ then do put (st,ts') -- back reference splits block
+ let (Target entry, Source source) = (t',s')
+ return (take entry xs, [])
+ else do put (st',ts)
+ let
+ _ -> undefined
+
+-}
+getCFG :: FilePath -> B.ByteString -> IO (Maybe CFG)
+getCFG file name = do context <- getMethodIO file name
+ return $ buildCFGContext context
+
+buildCFGContext :: MContext -> Maybe CFG
+buildCFGContext = liftM genCFGPure
+
+genCFGPure :: Context -> CFG
+genCFGPure (ins,cls) = let offsets = getInstOffsets ins
+ taggedInst = zip3 (map Source $ sumSeries'' offsets) offsets ins
+ cont = execState (findContinuations taggedInst) ([], H.empty)
+ in evalState (genCFGState taggedInst) (cont, M.empty)
+
+methodCodeM :: B.ByteString-> Maybe (Class Resolved)-> Maybe (Class Resolved, B.ByteString)
+methodCodeM name mcls = do cls <- mcls
+ ins <- methodCode cls name
+ return (cls,ins)
+
+getMethod :: FilePath-> B.ByteString-> IO (Maybe (B.ByteString, Class Resolved))
+getMethod file name = do cls <- parseClassFile file
+ return (methodCode cls name >>= \ins -> return (ins,cls))
+
+fullDecode :: (B.ByteString, t) -> ([J.Instruction], t)
+fullDecode (ins, cls) = (J.codeInstructions $ J.decodeMethod ins, cls)
+
+getMethodIO :: FilePath-> B.ByteString-> IO (Maybe ([J.Instruction], Class Resolved))
+getMethodIO file name = do context <- getMethod file name
+ return $ liftM fullDecode context
+
+
+genCFGState = undefined
+
+
projects / mate.git / blobdiff