scratch: stack->register mapping experiments. preparation for hoopl tests

diff --git a/scratch/Analysis.hs b/scratch/Analysis.hs
new file mode 100644 (file)
index 0000000..fb50ea1
--- /dev/null
+++ b/scratch/Analysis.hs
@@ -0,0 +1,60 @@
+module Analysis where
+
+import Control.Monad.State
+
+type Addr = Int
+
+data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type
+
+type Target = (Int,Type)
+type Source = (Int,Type)
+
+tmpReg = 10
+
+data RegIL = RMov Target Source | RAdd Target Source Source 
+             | RStore Addr Source | RLoad Source Addr deriving Show
+
+data Type = Int | Bottom deriving (Show,Eq)
+
+type StackElem = (Int,Type)
+
+type Stack = [StackElem]
+
+dup :: State Stack ()
+dup = modify (\(top@(i,t):x) -> (i+1,t) : top : xs)
+
+push :: Type -> State Stack Int
+push t = do tos <- get
+            case tos of 
+              top@(i,_):xs -> put ((i + 1, t) : top : xs) >> return i
+              [] -> put [(0,t)] >> return 0 
+
+pop :: State Stack StackElem
+pop = do x:xs <- get
+         put xs
+         return x
+
+nextElem :: State Stack Int
+nextElem = fmap ((+ 1) . fst . head) get
+
+aInterpret' :: StackIL -> State Stack [RegIL]
+aInterpret' Dup = dup >> return []
+aInterpret' (Ld addr t) = do s <- push t
+                             return [RLoad (s,t) addr]
+aInterpret' (Store addr t) = do (xA,tA) <- pop 
+                                return [RStore addr (xA,tA)]
+aInterpret' (Add t) = do (iA,ta) <- pop
+                         (iB,tb) <- pop 
+                         push ta
+                         if ta /= t || tb /=t then error "type mismatch in add"
+                            else return [ RAdd (tmpReg,ta) (iA,ta) (iB,tb), 
+                                          RMov (iB,tb) (tmpReg,ta)]
+
+aInterpret :: [StackIL] -> State Stack [RegIL]
+aInterpret = foldr (liftM2 (++) . aInterpret') (return [])
+
+generateRegisterIR :: [StackIL] -> [RegIL]
+generateRegisterIR = (`evalState` []) . aInterpret
+
+--data StackIL = Dup | Ld Addr Type | Add Type | Store Addr Type
+testCase1 = [ Ld 0 Int, Ld 1 Int, Dup , Add Int, Add Int, Store 0 Int]

diff --git a/scratch/GC.hs b/scratch/GC.hs
deleted file mode 100644 (file)
index c78eb50..0000000
--- a/scratch/GC.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ExistentialQuantification #-}
-module GC where
-
-import Control.Monad
-
-import Foreign.Ptr
-import Foreign.Marshal.Alloc
-import Foreign.Storable
-import Foreign.C.Types
-import GHC.Int
-import Text.Printf
-
-class RefObject a where
-  mem  :: a -> IntPtr 
-  refs :: a -> [IntPtr]
-
-
-data RefObj = RefObj IntPtr [IntPtr] deriving Show
-
-instance RefObject RefObj where
-  mem  (RefObj mem _ ) = mem
-  refs (RefObj _ refs) = refs
-
-data Succ = forall a. (RefObject a) => Succ (a -> [a])
-
-obj2 = do buffer <- mallocBytes 4
-          pokeByteOff buffer 0 (0::Int32)
-          return buffer
-
-obj3 = do buffer <- mallocBytes 4
-          pokeByteOff buffer 0 (0::Int32)
-          return buffer
-
-obj1 f g = do buffer <- mallocBytes 12
-              pokeByteOff buffer 0 (2::Int32)
-              pokeByteOff buffer 4 f
-              pokeByteOff buffer 8 g
-              return buffer
-
-ptrToRefObj ptr = do objCount <- peek ptr :: IO Int32
-                     let objsBase = ptr `plusPtr` 4
-                     objs <- mapM ((liftM ptrToIntPtr) . peekElemOff objsBase . fromIntegral) [0..objCount-1]
-                     return $ RefObj (ptrToIntPtr ptr) objs
-
-test1 = do f <- obj2
-           g <- obj3
-           (print . ptrToIntPtr) f
-           (print . ptrToIntPtr) g
-           ptrToRefObj =<< obj1 f g
-
-traverse :: (RefObject a) => (IntPtr -> IO a) -> a -> [a] -> IO [a]
-traverse dereference x ws = do children <- mapM dereference (refs x)
-                               undefined
-
-succMem :: Ptr a -> Succ
-succMem =undefined-- Succ (\_ -> obj1
-
-
-