scratch/Frontend.hs

   1 module Frontend where
   2
   3 import Data.Int
   4 import Data.Word
   5 import Control.Monad.State
   6 import Data.Maybe
   7 import Data.List
   8
   9 import JVM.ClassFile
  10 import JVM.Converter
  11 import JVM.Dump
  12 import JVM.Assembler
  13
  14 import qualified JVM.Assembler as J
  15 import qualified Data.Heap as H
  16 import qualified Data.ByteString.Lazy as B
  17 import qualified Data.Map as M
  18
  19
  20 import Debug.Trace
  21
  22 import Graph
  23
  24 {- Thoughs on types and representations
  25  - We start from constructing a CFG. What do we need here
  26  - ** Fast traversal which is aware of cycles
  27  - ** Fast successor, do we need predecessors?
  28  - ** Find all paths to current node (including back references)
  29  - ** Generic Node type in order to write mentioned operations
  30  -    generically. There should be no intermediate language "lock in"
  31  -    i.e. adding another IR should not kill CFG code
  32  -    Furthermore operations like SSA construction should
  33  -    not affect the CFG datastructure. Nodes contents should be
  34  -    interchangable in a way.
  35  - ** Some form of unique naming - we would like to identify blocks
  36  -    and check whether code should be produced for this node
  37  - ** Should be Haskell idiomatic - should be composed with
  38  -    standard haskell infrastructure
  39  - ** Convinient printing
  40  -
  41  - From this a inductive type should be appropriate?
  42  -
  43  -}
  44
  45
  46 -- Means NumberedINSruction
  47 type Size         = Int
  48 type NInst        = (Source, Size, J.Instruction)
  49 -- Putting Source and Target in data types prevents from interchanging ;-)
  50 data Source       = Source Int deriving (Eq, Ord, Show)
  51 data Target       = Target Int deriving (Eq, Ord, Show)
  52 -- Source, Target Instruction id
  53 type SourceTarget = (Source,Target)
  54 -- State type for findContinuations
  55 type ContState    = ([SourceTarget], H.MinPrioHeap Target Source)
  56
  57 data Block = BB [NInst] deriving (Show)
  58 type CFG = G Block
  59 data BlockID = Id Int deriving (Show,Ord,Eq)
  60
  61 type IndirectCFG = [([NInst],[Int],BlockID)]
  62
  63 data FinalBlock = FinalBlock BlockID [NInst] deriving (Show)
  64
  65 instance Eq FinalBlock where
  66   FinalBlock (Id x) _  == FinalBlock (Id y) _ = x == y
  67
  68 instance Ord FinalBlock where
  69   FinalBlock (Id x) _ <= FinalBlock (Id y) _ = x <= y
  70
  71 less :: Target -> Source -> Bool
  72 less (Target t) (Source s) = t < s
  73
  74 addW16Signed :: Int -> Word16 -> Int
  75 addW16Signed i w16 = i + fromIntegral s16
  76      where s16 = fromIntegral w16 :: Int16
  77
  78 getInstOffsets :: [J.Instruction] -> [Int]
  79 getInstOffsets = map (\i -> fromIntegral $ B.length $ J.encodeInstructions [i])
  80
  81 sumSeries'':: [Int] -> [Int]
  82 sumSeries'' =  reverse . snd . foldl (\(s,xs) x -> (s+x,s : xs)) (0,[])
  83
  84 splitBlocksBackRef :: [NInst] -> [Int]
  85 splitBlocksBackRef = concatMap checkSplit
  86     where checkSplit inst = case inst of
  87                              (Source s, size, IF_ICMP _ t) -> []
  88                              (Source s, size, GOTO      t) -> [addW16Signed s t]
  89                              _                             -> []
  90
  91
  92 getInstructions :: [Instruction] -> [(Source, Int, Instruction)]
  93 getInstructions ins = zip3 (map Source $ sumSeries'' offsets) offsets ins
  94                       where offsets = getInstOffsets ins
  95
  96
  97 getBranch :: NInst -> [Int]
  98 getBranch (Source s, size, IF_ICMP _ t) = [addW16Signed s t, s+size]
  99 getBranch (Source s, size, GOTO     t)  = [addW16Signed s t]
 100 getBranch (Source s, size, IRETURN   )  = [0] --actually wrong
 101 getBranch _                             = []
 102
 103 -- a version of Prelude.span whereby the first element
 104 -- which does not hold predicate f is also included in
 105 -- the first list
 106 spanPlus :: (a -> Bool) -> [a] -> ([a], [a])
 107 spanPlus _ []     = ([],[])
 108 spanPlus f (x:xs) = if f x then let (b, a) = spanPlus f xs
 109                                 in (x:b, a)
 110                            else ([x],xs)
 111
 112 fromNInst :: NInst -> Int
 113 fromNInst (Source s,_,_) = s
 114
 115 ifJust :: b -> Maybe a -> [b]
 116 ifJust _ Nothing  = []
 117 ifJust a (Just _) = [a]
 118
 119 splitBlocks :: [Int] -> [NInst] -> IndirectCFG
 120 splitBlocks _        [] = []
 121 splitBlocks backRefs xs = (map fst block, block >>= snd, Id id) : splitBlocks backRefs (map fst rest)
 122                           where getBranchAndRef ins@(Source i,w,_) =
 123                                    (ifJust (i+w) $ find (==i+w) backRefs) ++ getBranch ins
 124                                 branches     = zip xs $ map getBranchAndRef xs
 125                                 (block,rest) = spanPlus (null . snd) branches
 126                                 (Source id,_,_) = fst . head $ block -- block guarantted to be non empty
 127
 128 getTransitions :: IndirectCFG -> (M.Map BlockID [BlockID])
 129 getTransitions = foldr (\(_,targets,id) s -> M.insert id (map Id targets) s) M.empty
 130
 131 -- [([NInst],[Int],BlockID)]
 132 getNodes :: IndirectCFG -> [(BlockID,FinalBlock)]
 133 getNodes = map rearrange
 134    where rearrange (insts,_,id) = (id,FinalBlock id insts)
 135
 136
 137 --indirectCFGToG :: IndirectCFG -> G [NInst]
 138 indirectCFGToG cfg = toG packNodes (M.toList $ getTransitions cfg) (Id 0) (getNodes cfg)
 139
 140 {- DEPRECATED -}
 141
 142 findContinuations :: [NInst] -> State ContState ()
 143 findContinuations = mapM_ addCont
 144
 145 addCont :: NInst -> State ContState ()
 146 addCont (s, b, IF_ICMP _ w) = do add s (addTarget s w); jmpNext s b;
 147 addCont (s, _, GOTO      w) = add s (addTarget s w);
 148 addCont (s, b, _         )  = return () --jmpNext s b
 149
 150 jmpNext :: Source -> Int -> State ContState ()
 151 jmpNext s@(Source i) o = add s (Target $ i + o)
 152
 153
 154 addTarget :: Source -> Word16 -> Target
 155 addTarget (Source s) w16 = Target $ fromIntegral result
 156      where result =  s16 + fromIntegral w16 :: Int16
 157            s16    =  fromIntegral s :: Int16
 158
 159
 160
 161 addBranch :: Source -> Target -> State ContState ()
 162 addBranch s t = do (branches,backRefs) <- get
 163                    put ( (s,t) : branches, backRefs)
 164
 165 addBackRef :: Source -> Target -> State ContState ()
 166 addBackRef s t = do (branches,backRefs) <- get
 167                     put (branches, H.insert (t,s) backRefs)
 168
 169 add :: Source -> Target -> State ContState ()
 170 add s t = do addBranch s t
 171              -- if back branch - also add branch to back references
 172              -- for faster access later on
 173              if t `less` s then do trace ("jsadf") addBackRef s t;
 174                            else return ()
 175
 176
 177
 178 -- Context of the Method to be compiled
 179 type Context = ([J.Instruction],Class Resolved)
 180 -- Maybe a context of the Method to be compiled
 181 type MContext = Maybe Context
 182 -- The state for CFG creation
 183 type CFGState = (ContState, M.Map Int CFG)
 184
 185 type NodeState = ([(Source,Target)],[(Target,Source)])
 186 type IndirectGraph k a = ((M.Map k a),(M.Map k [k]))
 187
 188
 189
 190
 191
 192 minNext ::  Ord t => [t] -> [t] -> ([t], [t], Maybe t)
 193 minNext f@(x:xs) b@(y:ys) = if x < y then (xs, b, Just x)
 194                                      else (f, ys, Just y)
 195 minNext   (x:xs)   []     = (xs, [], Just x )
 196 minNext   []       (y:ys) = ([], ys, Just y )
 197 minNext   []       []     = ([], [], Nothing)
 198
 199 unpackst ((Source s), (Target t)) = (s,t)
 200 unpackts ((Target t), (Source s)) = (t,s)
 201
 202 --createNodes :: [NInst] -> ContState -> IndirectGraph Int Block
 203 --createNodes xs (forwardRefs, backwardRefs) = evalState (createNodes' xs) (branches, bRefs)
 204 --   where branches = map reverse forwardRefs
 205 --         bRefs    = map H.toAscList backwardRefs
 206
 207 --createNodes' ::[NInst] -> State NodeState (IndirectGraph Int Block)
 208 {-createNodes' xs = do (st,ts) <- get
 209                      case (st,ts) of
 210                        -- there are back refs and forward refs
 211                        ((s,t):st', (t',s'):ts')
 212                           -> if t' `less` s
 213                               then do put (st,ts') -- back reference splits block
 214                                       let (Target entry, Source source) = (t',s')
 215                                       return (take entry xs, [])
 216                               else do put (st',ts)
 217                                       let
 218                        _ -> undefined
 219
 220 -}
 221 getCFG ::  FilePath -> B.ByteString -> IO (Maybe CFG)
 222 getCFG file name = do context <- getMethodIO file name
 223                       return $ buildCFGContext context
 224
 225 buildCFGContext :: MContext -> Maybe CFG
 226 buildCFGContext = liftM genCFGPure
 227
 228 genCFGPure :: Context -> CFG
 229 genCFGPure (ins,cls) = let offsets    = getInstOffsets ins
 230                            taggedInst = zip3 (map Source $ sumSeries'' offsets) offsets ins
 231                            cont       = execState (findContinuations taggedInst) ([], H.empty)
 232                         in evalState (genCFGState taggedInst) (cont, M.empty)
 233
 234 methodCodeM :: B.ByteString-> Maybe (Class Resolved)-> Maybe (Class Resolved, B.ByteString)
 235 methodCodeM name mcls = do cls <- mcls
 236                            ins <- methodCode cls name
 237                            return (cls,ins)
 238
 239 getMethod :: FilePath-> B.ByteString-> IO (Maybe (B.ByteString, Class Resolved))
 240 getMethod file name = do cls <- parseClassFile file
 241                          return (methodCode cls name >>= \ins -> return (ins,cls))
 242
 243 fullDecode ::  (B.ByteString, t) -> ([J.Instruction], t)
 244 fullDecode (ins, cls) = (J.codeInstructions $ J.decodeMethod ins, cls)
 245
 246 getMethodIO :: FilePath-> B.ByteString-> IO (Maybe ([J.Instruction], Class Resolved))
 247 getMethodIO file name = do context <- getMethod file name
 248                            return $ liftM fullDecode context
 249
 250
 251 genCFGState = undefined
 252
 253