X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=scratch%2FFrontend.hs;fp=scratch%2FFrontend.hs;h=66b3cb96ac140d20d4901cd792989f8e9b804a64;hb=22d68f8f5c4abc1cd1e29a65a01be0a9d38f5296;hp=0000000000000000000000000000000000000000;hpb=058aeb878920fa34c8242fd65bd4830e82b90cf6;p=mate.git

diff --git a/scratch/Frontend.hs b/scratch/Frontend.hs
new file mode 100644
index 0000000..66b3cb9
--- /dev/null
+++ b/scratch/Frontend.hs
@@ -0,0 +1,252 @@
+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
+
+