scratch/ScratchHS.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4
   5 -- Purpose of this file is just do test some Intermediate representations and stuff ;-)
   6
   7 {- Some important material:
   8  -
   9  - Java HotSpot™ Client Compiler: www.cdl.uni-saarland.de/ssasem/talks/Christian.Wimmer.pdf
  10  - http://www.complang.tuwien.ac.at/andi/185A50
  11  -
  12  - [Poletto:1999] http://dl.acm.org/citation.cfm?doid=330249.330250
  13  - [Wimmer:2010] http://dl.acm.org/citation.cfm?id=1772954.1772979
  14  -
  15  -}
  16
  17
  18 module ScratchHS where
  19
  20 import Data.Maybe
  21 import qualified Data.Set as Set
  22 import Data.Set (Set)
  23 import Control.Monad.State
  24
  25 import Harpy
  26 import Harpy.X86Disassembler
  27
  28 import Foreign
  29 import Control.Monad
  30
  31 import JVM.ClassFile
  32 import JVM.Converter
  33 import JVM.Dump
  34
  35 import qualified JVM.Assembler as JAsm
  36
  37 import Mate.Utilities
  38 import Mate.BasicBlocks
  39
  40 $(callDecl "callAsWord32" [t|Word32|])
  41
  42 data SimpleStack = PushLit Int
  43                  | Mul
  44                  | Add
  45                  | Ld String
  46                  | Print
  47
  48 testP = [PushLit 3, PushLit 2, Mul]
  49
  50 type Reg = Int
  51 data ROp = RMul | RAdd
  52
  53 data RegIL = RMov Reg Reg
  54            | RLoad Reg String
  55            | RBin  Reg Reg Reg ROp
  56
  57 data MateState = MateState String
  58
  59 compileRegIL :: RegIL -> CodeGen (Ptr Int32) MateState ()
  60 compileRegIL (RMov t s) = do
  61                            mateState <- getState
  62                            let (mt,ms) = (eax,eax)
  63                            mov mt ms
  64
  65
  66 entryCode :: CodeGen e s ()
  67 entryCode = do push ebp
  68                mov ebp esp
  69
  70 exitCode :: CodeGen e s ()
  71 exitCode = do mov esp ebp
  72               pop ebp
  73               ret
  74
  75
  76
  77 run :: [RegIL] -> Ptr Int32 -> IO (MateState, Either ErrMsg [Instruction])
  78 run program env = let compileAndFeedback = mapM_ compileRegIL program >> disassemble
  79                   in runCodeGen compileAndFeedback env (MateState "none")
  80
  81
  82 -- Allocates a buffer with size n. All zero.
  83 emptyMemory ::  (Storable a, Num a) => Int -> IO (Ptr a)
  84 emptyMemory n = mallocArray n
  85                   >>= (\ptr -> pokeArray ptr (replicate n 0) >> return ptr)
  86
  87
  88 testEnv p' = do
  89               ptr <- emptyMemory 26
  90               (_, Right code) <- run p' ptr
  91               return $ map showIntel code
  92
  93
  94 simpleTest ::  [RegIL]
  95 simpleTest = [RMov 0 1]
  96
  97
  98 -- Just some class file sand
  99 loadMethod methodName classFile = do cls <- parseClassFile classFile
 100                                      dumpClass cls
 101                                      return (cls, lookupMethod methodName cls)
 102
 103
 104 getFib = do (cls, Just m) <- loadMethod "ackermann" "../tests/Ackermann.class"
 105             return (cls, m)
 106
 107 fibBasicBlocks = do (cls,m) <- getFib
 108                     hmap <- parseMethod cls "ackermann"
 109                     printMapBB hmap
 110                     return ()
 111
 112
 113 {- Thoughs on types and representations
 114  - We start from constructing a CFG. What do we need here
 115  - ** Fast traversal which is aware of cycles
 116  - ** Fast successor, do we need predecessors?
 117  - ** Find all paths to current node (including back references)
 118  - ** Generic Node type in order to write mentioned operations
 119  -    generically. There should be no intermediate language "lock in"
 120  -    i.e. adding another IR should not kill CFG code
 121  -    Furthermore operations like SSA construction should
 122  -    not affect the CFG datastructure. Nodes contents should be
 123  -    interchangable in a way.
 124  - ** Some form of unique naming - we would like to identify blocks
 125  -    and check whether code should be produced for this node
 126  - ** Should be Haskell idiomatic - should be composed with
 127  -    standard haskell infrastructure
 128  - ** Convinient printing
 129  -
 130  - From this a inductive type should be appropriate?
 131  -
 132  -}
 133
 134 data G a = Node  a (G a) (G a)
 135          | Leaf  a
 136          | Nil deriving(Show)
 137
 138 type LoopCheck a = Set a
 139
 140
 141 {- Actually i am not sure about the cata and algebra definition.
 142  -
 143  - check: http://dl.acm.org/citation.cfm?id=128035
 144  -}
 145
 146 type TreeAlgebra a r = (a -> r, r -> r -> r)
 147
 148 foldG :: TreeAlgebra a r -> r -> G a -> r
 149 foldG (f,g) s (Leaf val)     = g (f val) s
 150 foldG (f,g) s (Node val l r) = g (f val) $ g (foldG (f,g) s l) (foldG (f,g) s r)
 151
 152 printG = foldG ((: []), (++)) []
 153
 154 loopCheck :: (Ord k) => G a -> (G a -> k) -> State (LoopCheck k) Bool
 155 loopCheck g f = do state <- get
 156                    return $ Set.member (f g) state
 157
 158 addNode :: (Ord k) => k -> State (LoopCheck k) ()
 159 addNode k = do s <- get
 160                put $ Set.insert k s
 161                return ()
 162
 163 foldGM :: (Ord k) => TreeAlgebra a r -> (G a -> k) -> r -> G a -> State (LoopCheck k) r
 164 foldGM _     _ s    Nil           = return s
 165 foldGM (f,g) c s k@(Leaf val)     = loopCheck k c >>= \p -> if p then return s else return $ g (f val) s
 166 foldGM (f,g) c s k@(Node val l r) = loopCheck k c >>= \p -> if p then return s else continue
 167                                     where t        = foldGM (f,g) c s
 168                                           self     = g (f val)
 169                                           continue = do addNode $ c k
 170                                                         left  <- t l
 171                                                         right <- t r
 172                                                         return $ self $ g left right
 173
 174 diamant ::  G String
 175 diamant = let start = Node "a" left right
 176               left  = Node "l" end Nil
 177               right = Node "r" end Nil
 178               end   = Node "g" start Nil
 179           in start
 180
 181 dag = Node "a" (Node "b" (Leaf "c") (Leaf "d")) (Node "b" (Leaf "c") (Leaf "d"))
 182
 183
 184 value (Node val _ _) = Just val
 185 value (Leaf val    ) = Just val
 186 value Nil            = Nothing
 187
 188
 189 printG' ::  Ord k => G k -> [k]
 190 printG' g = evalState (foldGM ((: []), (++)) (\node -> let (Just v) = value node in v) [] g) Set.empty
 191
 192
 193
 194
 195 {- stupid sketch code -}
 196
 197 -- actually loop check does not work properly. use monadic version instead
 198 foldG' :: (Ord k) => TreeAlgebra a r -> (G a -> k) -> r -> Set k -> G a -> r
 199 foldG' (f,g) c s s' Nil              = s
 200 foldG' (f,g) c s s' k@(Leaf val)     = if Set.member (c k) s' then s else g (f val) s
 201 foldG' (f,g) c s s' k@(Node val l r) = if Set.member (c k) s' then s
 202                                        else let newState = Set.insert (c k) s'
 203                                                 left  = foldG' (f,g) c s newState l
 204                                                 right = foldG' (f,g) c s newState r
 205                                              in g (f val) $ g left right
 206
 207