scratch/ScratchHS.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TemplateHaskell #-}
   5
   6 -- Purpose of this file is just do test some Intermediate representations and stuff ;-)
   7
   8 {- Some important material:
   9  -
  10  - Java HotSpot™ Client Compiler: www.cdl.uni-saarland.de/ssasem/talks/Christian.Wimmer.pdf
  11  - http://www.complang.tuwien.ac.at/andi/185A50
  12  -
  13  - [Poletto:1999] http://dl.acm.org/citation.cfm?doid=330249.330250
  14  - [Wimmer:2010] http://dl.acm.org/citation.cfm?id=1772954.1772979
  15  -
  16  -}
  17
  18
  19 module ScratchHS where
  20
  21 import Data.Maybe
  22 import Control.Monad.State
  23
  24 import Harpy hiding(fst,add)
  25 import qualified Harpy.X86Disassembler as H
  26 import qualified Data.ByteString.Lazy as B
  27 import qualified Data.Set as S
  28 import qualified Data.Heap as H
  29
  30 import Foreign
  31
  32 import Debug.Trace
  33 import Data.Int
  34
  35 import JVM.ClassFile
  36 import JVM.Converter
  37 import JVM.Dump
  38
  39 import JVM.Assembler
  40
  41 import Mate.Utilities
  42 import Mate.BasicBlocks
  43
  44 import Frontend
  45 import Graph
  46
  47 $(callDecl "callAsWord32" [t|Word32|])
  48
  49 data SimpleStack = PushLit Int
  50                  | Mul
  51                  | Add
  52                  | Ld String
  53                  | Print
  54
  55 testP = [PushLit 3, PushLit 2, Mul]
  56
  57 type Reg = Int
  58 data ROp = RMul | RAdd
  59
  60 data RegIL = RMov Reg Reg
  61            | RLoad Reg String
  62            | RBin  Reg Reg Reg ROp
  63
  64 data MateState = MateState String
  65
  66 compileRegIL :: RegIL -> CodeGen (Ptr Int32) MateState ()
  67 compileRegIL (RMov t s) = do
  68                            mateState <- getState
  69                            let (mt,ms) = (eax,eax)
  70                            mov mt ms
  71
  72
  73 entryCode :: CodeGen e s ()
  74 entryCode = do push ebp
  75                mov ebp esp
  76
  77 exitCode :: CodeGen e s ()
  78 exitCode = do mov esp ebp
  79               pop ebp
  80               ret
  81
  82
  83
  84 run :: [RegIL] -> Ptr Int32 -> IO (MateState, Either ErrMsg [H.Instruction])
  85 run program env = let compileAndFeedback = mapM_ compileRegIL program >> disassemble
  86                   in runCodeGen compileAndFeedback env (MateState "none")
  87
  88
  89 -- Allocates a buffer with size n. All zero.
  90 emptyMemory ::  (Storable a, Num a) => Int -> IO (Ptr a)
  91 emptyMemory n = mallocArray n
  92                   >>= (\ptr -> pokeArray ptr (replicate n 0) >> return ptr)
  93
  94
  95 testEnv p' = do
  96               ptr <- emptyMemory 26
  97               (_, Right code) <- run p' ptr
  98               return $ map H.showIntel code
  99
 100
 101 simpleTest ::  [RegIL]
 102 simpleTest = [RMov 0 1]
 103
 104
 105 -- Just some class file sand
 106 loadMethod methodName classFile = do cls <- parseClassFile classFile
 107                                      dumpClass cls
 108                                      return (cls, lookupMethod methodName cls)
 109
 110
 111 getFib = do (cls, Just m) <- loadMethod "fac" "../tests/Fac.class"
 112             return (cls, m)
 113
 114 fibBasicBlocks = do (cls,m) <- getFib
 115                     hmap <- parseMethod cls "facFor"
 116                     printMapBB hmap
 117                     return ()
 118
 119
 120 fib = do con@(Just (ins,cls)) <- getMethodIO "../tests/Fac.class" "facFor"
 121          let offsets = getInstOffsets ins
 122          let taggedInst = zip3 (map Source $ sumSeries'' offsets) offsets ins
 123          mapM_ print taggedInst
 124          let continuations =  execState (findContinuations taggedInst) ([],H.empty)
 125          print continuations
 126          let cfg = buildCFGContext con
 127          print cfg
 128          return cfg
 129
 130 fib' = do con@(Just (ins,cls)) <- getMethodIO "../tests/Fac.class" "facFor"
 131           let tagged = getInstructions ins
 132           print tagged
 133           let backRefs = splitBlocksBackRef tagged
 134           let splitted = splitBlocks backRefs tagged
 135           print splitted
 136           let transitions = getTransitions splitted
 137           let nodes       = getNodes splitted
 138           print "nodes:"
 139           print nodes
 140           print "transitions"
 141           print transitions
 142           let (Just finalCyclicStructure) = indirectCFGToG splitted
 143           print "Final result"
 144           print $ printG' finalCyclicStructure
 145
 146 main = do con@(Just (ins,cls)) <- getMethodIO "../tests/AbsurdlyHuge.class" "absurdlyHuge"
 147           let tagged = getInstructions ins
 148           let backRefs = splitBlocksBackRef tagged
 149           let splitted = splitBlocks backRefs tagged
 150           let transitions = getTransitions splitted
 151           let nodes       = getNodes splitted
 152           print "nodes:"
 153           print nodes
 154           print "transitions"
 155           print transitions
 156           let (Just finalCyclicStructure) = indirectCFGToG splitted
 157           print "Final result"
 158           print $ printG' finalCyclicStructure
 159
 160
 161
 162
 163 diamant ::  G String
 164 diamant = let start = Node "a" left right
 165               left  = Node "l" end Nil
 166               right = Node "r" end Nil
 167               end   = Node "g" start Nil
 168           in start
 169
 170 dag = Node "a" (Node "b" (Leaf "c") (Leaf "d")) (Node "b" (Leaf "c") (Leaf "d"))
 171
 172
 173 value (Node val _ _) = Just val
 174 value (Leaf val    ) = Just val
 175 value Nil            = Nothing
 176
 177
 178 printG' ::  Ord k => G k -> [k]
 179 printG' g = evalState (foldGM ((: []), (++)) (\node -> let (Just v) = value node in v) [] g) S.empty