CodeGenMonad: add Functor instance

[harpy.git] / Harpy / CodeGenMonad.hs

diff --git a/Harpy/CodeGenMonad.hs b/Harpy/CodeGenMonad.hs
index 20e81ddfefe328ba1d29d1afe455387c0c232fa9..94d68a1182977a6ba3823fb9dc030c5c0b69f9cd 100644 (file)
--- a/Harpy/CodeGenMonad.hs
+++ b/Harpy/CodeGenMonad.hs
@@ -86,6 +86,7 @@ import Numeric
 import Data.List
 import qualified Data.Map as Map
 import Foreign
+import Foreign.C.Types
 import System.IO
 
 import Control.Monad.Trans
@@ -172,6 +173,9 @@ instance Monad (CodeGen e s) where
     fail err = cgFail err
     m >>= k = cgBind m k
 
+instance Functor (CodeGen e s) where
+  fmap = liftM
+
 cgReturn :: a -> CodeGen e s a
 cgReturn x = CodeGen (\_env state -> return (state, Right x))
 
@@ -225,6 +229,20 @@ runCodeGen :: CodeGen e s a -> e -> s -> IO (s, Either ErrMsg a)
 runCodeGen cg uenv ustate =
     runCodeGenWithConfig cg uenv ustate defaultCodeGenConfig
 
+foreign import ccall "static stdlib.h"
+  memalign :: CUInt -> CUInt -> IO (Ptr a)
+
+foreign import ccall "static sys/mman.h"
+  mprotect :: CUInt -> CUInt -> Int -> IO Int
+
+mallocExecBytes :: Int -> IO (Ptr a)
+mallocExecBytes size' = do
+    arr <- memalign 0x1000 size
+    -- 0x7 = PROT_{READ,WRITE,EXEC}
+    _ <- mprotect (fromIntegral $ ptrToIntPtr arr) size 0x7
+    return arr
+  where size = fromIntegral size'
+
 -- | Like 'runCodeGen', but allows more control over the code
 -- generation process.  In addition to a code generator and a user
 -- environment and state, a code generation configuration must be
@@ -234,7 +252,7 @@ runCodeGenWithConfig :: CodeGen e s a -> e -> s -> CodeGenConfig -> IO (s, Eithe
 runCodeGenWithConfig (CodeGen cg) uenv ustate conf =
     do (buf, sze) <- case customCodeBuffer conf of
                        Nothing -> do let initSize = codeBufferSize conf
-                                     arr <- mallocBytes initSize
+                                     arr <- mallocExecBytes initSize
                                      return (arr, initSize)
                        Just (buf, sze) -> return (buf, sze)
        let env = CodeGenEnv {tailContext = True}
@@ -281,7 +299,7 @@ ensureBufferSize needed =
          Nothing ->
              unless (bufferOfs state + needed + 5 <= bufferSize state)
                         (do let incrSize = max (needed + 16) (codeBufferSize (config state))
-                            arr <- liftIO $ mallocBytes incrSize
+                            arr <- liftIO $ mallocExecBytes incrSize
                             ofs <- getCodeOffset
                             let buf = buffer state
                                 disp :: Int
@@ -515,9 +533,12 @@ disassemble = do
  where insertLabels :: [Dis.Instruction] -> CodeGen e s [Dis.Instruction]
        insertLabels = liftM concat . mapM ins
        ins :: Dis.Instruction -> CodeGen e s [Dis.Instruction]
-       ins i@(Dis.BadInstruction{}) = return [i]
+       ins i@(Dis.BadInstruction _ _ addr _) = insWithLabel i addr
        ins i@(Dis.PseudoInstruction{}) = return [i]
-       ins i@(Dis.Instruction{Dis.address = addr}) =
+       ins i@(Dis.Instruction{Dis.address = addr}) = insWithLabel i addr
+
+       insWithLabel :: Dis.Instruction -> Int -> CodeGen e s [Dis.Instruction]
+       insWithLabel i addr =
            do state <- getInternalState
               let allLabs = Map.toList (definedLabels state)
                   labs = filter (\ (_, (buf, ofs, _)) -> fromIntegral (ptrToWordPtr (buf `plusPtr` ofs)) == addr) allLabs