From: Harald Steinlechner Date: Wed, 18 Apr 2012 19:06:56 +0000 (+0200) Subject: scratch: checked out some abstractions, sandboxing, mostly broken ;-) X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=b675cd76aeebdd9071b4ac6323e59c4b632ab651 scratch: checked out some abstractions, sandboxing, mostly broken ;-) tests: added for version of fac to Fac --- diff --git a/scratch/ScratchHS.hs b/scratch/ScratchHS.hs index b0b60bd..2fa05fd 100644 --- a/scratch/ScratchHS.hs +++ b/scratch/ScratchHS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -20,23 +21,35 @@ module ScratchHS where import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) +import qualified Data.Map as M +import Data.Map (Map) import Control.Monad.State -import Harpy -import Harpy.X86Disassembler +import qualified Data.Heap as H +--import qualified Data.Heap as M + +import Harpy hiding(fst,add) +import qualified Harpy.X86Disassembler as H import Foreign import Control.Monad +import Debug.Trace +import Data.Int + import JVM.ClassFile import JVM.Converter import JVM.Dump -import qualified JVM.Assembler as JAsm +import qualified JVM.Assembler as J +import JVM.Assembler import Mate.Utilities import Mate.BasicBlocks +import qualified Data.ByteString.Lazy as B + + $(callDecl "callAsWord32" [t|Word32|]) data SimpleStack = PushLit Int @@ -74,7 +87,7 @@ exitCode = do mov esp ebp -run :: [RegIL] -> Ptr Int32 -> IO (MateState, Either ErrMsg [Instruction]) +run :: [RegIL] -> Ptr Int32 -> IO (MateState, Either ErrMsg [H.Instruction]) run program env = let compileAndFeedback = mapM_ compileRegIL program >> disassemble in runCodeGen compileAndFeedback env (MateState "none") @@ -88,7 +101,7 @@ emptyMemory n = mallocArray n testEnv p' = do ptr <- emptyMemory 26 (_, Right code) <- run p' ptr - return $ map showIntel code + return $ map H.showIntel code simpleTest :: [RegIL] @@ -101,11 +114,11 @@ loadMethod methodName classFile = do cls <- parseClassFile classFile return (cls, lookupMethod methodName cls) -getFib = do (cls, Just m) <- loadMethod "ackermann" "../tests/Ackermann.class" +getFib = do (cls, Just m) <- loadMethod "fac" "../tests/Fac.class" return (cls, m) fibBasicBlocks = do (cls,m) <- getFib - hmap <- parseMethod cls "ackermann" + hmap <- parseMethod cls "facFor" printMapBB hmap return () @@ -171,6 +184,232 @@ foldGM (f,g) c s k@(Node val l r) = loopCheck k c >>= \p -> if p then return s e right <- t r return $ self $ g left right +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 + + + +{- CFG generation + - ...... + -} + +-- 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 = (H.MinPrioHeap Target Source, H.MinPrioHeap Source Target) + +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 _ = return (); + +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 + + +addW16Signed :: Int -> Word16 -> Int +addW16Signed i w16 = i + fromIntegral s16 + where s16 = fromIntegral w16 :: Int16 + + +add :: Source -> Target -> State ContState () +add s t = do (targetSource,sourceTarget) <- get + put (H.insert (t, s) targetSource, H.insert (s,t) sourceTarget) + +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,[]) + + + +data Block = BB [NInst] deriving (Show) +type CFG = G Block + +-- 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) + + +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,H.empty) + in evalState (genCFGState taggedInst) (cont, M.empty) + + +joinM :: Maybe a -> Maybe b -> Maybe (a,b) +joinM Nothing _ = Nothing +joinM _ Nothing = Nothing +joinM (Just a) (Just b) = Just (a,b) + +joinM' = uncurry joinM + +leq :: Target -> Source -> Bool +leq (Target t) (Source s) = t <= s + +getCont :: State CFGState ContState +getCont = do ((ts,st),_) <- get + return (ts,st) + + +takeTill :: Int -> [NInst] -> ([NInst],[NInst]) +takeTill ref = span (\(Source loc,s,inst) -> loc < ref) + + +writeBack :: ContState -> State CFGState () +writeBack s = do (_,cls) <- get + put (s,cls) + +from :: Int -> [NInst] -> [NInst] +from ref = dropWhile (\(Source loc,s,inst) -> loc < ref) + + +data Branch = BackRef Target Source + | ForwardRef Source [Target] deriving (Show) + + + +getForwardRef ts s' t' restForward restBack = + do writeBack (ts, restForward) -- remove forward ref from state + -- maybe this one is a twoRef + anotherOne <- getNextBranch + case anotherOne of + Just (ForwardRef s'' t'') + -- If the next reference has the same source concat them + -> if s'' == s' then return $ Just $ ForwardRef s' (t' : t'') + else return $ Just $ ForwardRef s' [t'] + Nothing -> --fail ("bahh" ++ show s' ++ show t') + return $ Just $ ForwardRef s' [t'] + +getNextBranch :: State CFGState (Maybe Branch) +getNextBranch = do ((ts,st),m) <- get + case joinM' (H.view ts, H.view st) of + -- Here we found the next front and the next back reference. + -- which one is earlier + Just ( ( (t,s), restBack), ( (s',t'), restForward) ) + -> if t `leq` s + then -- back reference + do writeBack (restBack, st) -- remove back reference from ref state + return $ Just $ BackRef t s + else -- forward reference + --getForwardRef ts s' t' restForward restBack + do writeBack (ts,restForward) + return $ Just $ ForwardRef s' [t'] + Nothing -> return Nothing + + +genCFGState :: [NInst] -> State CFGState CFG +genCFGState xs = do nextBranch <- getNextBranch + case nextBranch of + Nothing -> return $ Leaf $ BB xs + Just (BackRef (Target t) (Source s)) + -> do + let (previousBlock,rest) = takeTill t xs + (refs,m) <- get + let patched = let p = M.insert s c m + c = evalState (genCFGState rest) (refs,p) + in c + return patched + Just (ForwardRef _ _) + -> do (_,m) <- get + let t = 4 + fail "sjdf" + case M.lookup t m of + Nothing -> return $ Leaf $ BB xs + Just b -> return (Node (BB xs) b Nil) + _ -> fail (show nextBranch) + -- return $ Leaf $ BB xs +{- +genCFGState :: [NInst] -> State CFGState (CFG, M.Map Source CFG) +genCFGState xs = do (ts,st) <- getCont + case joinM' (H.view ts, H.view st) of + Just ( ( (t, s), backRef), ( (s', t'), sndBranch) ) + -> if t `leq` s then do writeBack (backRef,st); + runUntilBackRef (t , s ) + else runUntilBranch (s', t') sndBranch ts + Nothing + -> runUntilExit + where + -- There is no back reference left. Run block until Control leaves. + runUntilExit = fail "run until exit" --Nothing = return takeWhile (\(s,w,inst) -> undefined) undefined + + -- In the program future a goto lands at this instruction. + runUntilBackRef (Target ref,_) = + do + let (block,rest) = takeTill ref xs + (followUpBlock,_) <- genCFGState rest + let cfg = Node (BB block) followUpBlock Nil + return $ (cfg, M.empty) + + runUntilBranch (Source s,Target t) st ts = + do + let (block,rest) = takeTill (s+1) xs + -- check wheter this instruction branches also to another location + case H.view st of + Just ((Source sndBr, Target t),restBranches) + -> if sndBr == s then do writeBack (ts,restBranches) + twoBranch sndBr t block + else oneBranch block + Nothing -> oneBranch block + where twoBranch sndBranch t' block = + do (left, _) <- genCFGState $ from t xs + (right,_) <- genCFGState $ from t' xs + return $ (Node (BB block) left right, M.empty) + oneBranch block = return (Leaf (BB block), M.empty) --fail $ "oneBranch" ++ (show s) ++ " " ++ (show st) +-} + +fib = do con@(Just (ins,cls)) <- getMethodIO "../tests/Fac.class" "facFor" + let offsets = getInstOffsets ins + let taggedInst = zip3 (map Source $ sumSeries'' offsets) offsets ins + mapM_ print taggedInst + let continuations = execState (findContinuations taggedInst) (H.empty, H.empty) + print continuations + let cfg = buildCFGContext con + print cfg + return cfg + + + diamant :: G String diamant = let start = Node "a" left right left = Node "l" end Nil @@ -188,20 +427,3 @@ value Nil = Nothing printG' :: Ord k => G k -> [k] printG' g = evalState (foldGM ((: []), (++)) (\node -> let (Just v) = value node in v) [] g) Set.empty - - - - -{- stupid sketch code -} - --- actually loop check does not work properly. use monadic version instead -foldG' :: (Ord k) => TreeAlgebra a r -> (G a -> k) -> r -> Set k -> G a -> r -foldG' (f,g) c s s' Nil = s -foldG' (f,g) c s s' k@(Leaf val) = if Set.member (c k) s' then s else g (f val) s -foldG' (f,g) c s s' k@(Node val l r) = if Set.member (c k) s' then s - else let newState = Set.insert (c k) s' - left = foldG' (f,g) c s newState l - right = foldG' (f,g) c s newState r - in g (f val) $ g left right - - diff --git a/tests/Fac.java b/tests/Fac.java index 49ddbc6..e1cf188 100644 --- a/tests/Fac.java +++ b/tests/Fac.java @@ -16,4 +16,13 @@ public class Fac { } return b; } + + public static int facFor(int n){ + int p = 1; + for(int i=1;i<=n;i++) + { + p = p * i; + } + return p; + } }