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 _                             = []
 101
 102 -- a version of Prelude.span whereby the first element
 103 -- which does not hold predicate f is also included in
 104 -- the first list
 105 spanPlus :: (a -> Bool) -> [a] -> ([a], [a])
 106 spanPlus _ []     = ([],[])
 107 spanPlus f (x:xs) = if f x then let (b, a) = spanPlus f xs
 108                                 in (x:b, a)
 109                            else ([x],xs)
 110
 111 fromNInst :: NInst -> Int
 112 fromNInst (Source s,_,_) = s
 113
 114 ifJust :: b -> Maybe a -> [b]
 115 ifJust _ Nothing  = []
 116 ifJust a (Just _) = [a]
 117
 118 splitBlocks :: [Int] -> [NInst] -> IndirectCFG
 119 splitBlocks _        [] = []
 120 splitBlocks backRefs xs = (map fst block, block >>= snd, Id id) : splitBlocks backRefs (map fst rest)
 121                           where getBranchAndRef ins@(Source i,w,_) =
 122                                    (ifJust (i+w) $ find (==i+w) backRefs) ++ getBranch ins
 123                                 branches     = zip xs $ map getBranchAndRef xs
 124                                 (block,rest) = spanPlus (null . snd) branches
 125                                 (Source id,_,_) = fst . head $ block -- block guarantted to be non empty
 126
 127 getTransitions :: IndirectCFG -> (M.Map BlockID [BlockID])
 128 getTransitions = foldr (\(_,targets,id) s -> M.insert id (map Id targets) s) M.empty
 129
 130 -- [([NInst],[Int],BlockID)]
 131 getNodes :: IndirectCFG -> [(BlockID,FinalBlock)]
 132 getNodes = map rearrange
 133    where rearrange (insts,_,id) = (id,FinalBlock id insts)
 134
 135
 136 --indirectCFGToG :: IndirectCFG -> G [NInst]
 137 indirectCFGToG cfg = toG packNodes (M.toList $ getTransitions cfg) (Id 0) (getNodes cfg)
 138
 139 {- DEPRECATED -}
 140
 141 findContinuations :: [NInst] -> State ContState ()
 142 findContinuations = mapM_ addCont
 143
 144 addCont :: NInst -> State ContState ()
 145 addCont (s, b, IF_ICMP _ w) = do add s (addTarget s w); jmpNext s b;
 146 addCont (s, _, GOTO      w) = add s (addTarget s w);
 147 addCont (s, b, _         )  = return () --jmpNext s b
 148
 149 jmpNext :: Source -> Int -> State ContState ()
 150 jmpNext s@(Source i) o = add s (Target $ i + o)
 151
 152
 153 addTarget :: Source -> Word16 -> Target
 154 addTarget (Source s) w16 = Target $ fromIntegral result
 155      where result =  s16 + fromIntegral w16 :: Int16
 156            s16    =  fromIntegral s :: Int16
 157
 158
 159
 160 addBranch :: Source -> Target -> State ContState ()
 161 addBranch s t = do (branches,backRefs) <- get
 162                    put ( (s,t) : branches, backRefs)
 163
 164 addBackRef :: Source -> Target -> State ContState ()
 165 addBackRef s t = do (branches,backRefs) <- get
 166                     put (branches, H.insert (t,s) backRefs)
 167
 168 add :: Source -> Target -> State ContState ()
 169 add s t = do addBranch s t
 170              -- if back branch - also add branch to back references
 171              -- for faster access later on
 172              if t `less` s then do trace ("jsadf") addBackRef s t;
 173                            else return ()
 174
 175
 176
 177 -- Context of the Method to be compiled
 178 type Context = ([J.Instruction],Class Resolved)
 179 -- Maybe a context of the Method to be compiled
 180 type MContext = Maybe Context
 181 -- The state for CFG creation
 182 type CFGState = (ContState, M.Map Int CFG)
 183
 184 type NodeState = ([(Source,Target)],[(Target,Source)])
 185 type IndirectGraph k a = ((M.Map k a),(M.Map k [k]))
 186
 187
 188
 189
 190
 191 minNext ::  Ord t => [t] -> [t] -> ([t], [t], Maybe t)
 192 minNext f@(x:xs) b@(y:ys) = if x < y then (xs, b, Just x)
 193                                      else (f, ys, Just y)
 194 minNext   (x:xs)   []     = (xs, [], Just x )
 195 minNext   []       (y:ys) = ([], ys, Just y )
 196 minNext   []       []     = ([], [], Nothing)
 197
 198 unpackst ((Source s), (Target t)) = (s,t)
 199 unpackts ((Target t), (Source s)) = (t,s)
 200
 201 --createNodes :: [NInst] -> ContState -> IndirectGraph Int Block
 202 --createNodes xs (forwardRefs, backwardRefs) = evalState (createNodes' xs) (branches, bRefs)
 203 --   where branches = map reverse forwardRefs
 204 --         bRefs    = map H.toAscList backwardRefs
 205
 206 --createNodes' ::[NInst] -> State NodeState (IndirectGraph Int Block)
 207 {-createNodes' xs = do (st,ts) <- get
 208                      case (st,ts) of
 209                        -- there are back refs and forward refs
 210                        ((s,t):st', (t',s'):ts')
 211                           -> if t' `less` s
 212                               then do put (st,ts') -- back reference splits block
 213                                       let (Target entry, Source source) = (t',s')
 214                                       return (take entry xs, [])
 215                               else do put (st',ts)
 216                                       let
 217                        _ -> undefined
 218
 219 -}
 220 getCFG ::  FilePath -> B.ByteString -> IO (Maybe CFG)
 221 getCFG file name = do context <- getMethodIO file name
 222                       return $ buildCFGContext context
 223
 224 buildCFGContext :: MContext -> Maybe CFG
 225 buildCFGContext = liftM genCFGPure
 226
 227 genCFGPure :: Context -> CFG
 228 genCFGPure (ins,cls) = let offsets    = getInstOffsets ins
 229                            taggedInst = zip3 (map Source $ sumSeries'' offsets) offsets ins
 230                            cont       = execState (findContinuations taggedInst) ([], H.empty)
 231                         in evalState (genCFGState taggedInst) (cont, M.empty)
 232
 233 methodCodeM :: B.ByteString-> Maybe (Class Resolved)-> Maybe (Class Resolved, B.ByteString)
 234 methodCodeM name mcls = do cls <- mcls
 235                            ins <- methodCode cls name
 236                            return (cls,ins)
 237
 238 getMethod :: FilePath-> B.ByteString-> IO (Maybe (B.ByteString, Class Resolved))
 239 getMethod file name = do cls <- parseClassFile file
 240                          return (methodCode cls name >>= \ins -> return (ins,cls))
 241
 242 fullDecode ::  (B.ByteString, t) -> ([J.Instruction], t)
 243 fullDecode (ins, cls) = (J.codeInstructions $ J.decodeMethod ins, cls)
 244
 245 getMethodIO :: FilePath-> B.ByteString-> IO (Maybe ([J.Instruction], Class Resolved))
 246 getMethodIO file name = do context <- getMethod file name
 247                            return $ liftM fullDecode context
 248
 249
 250 genCFGState = undefined
 251
 252