diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 1.0.5 +version: 1.0.7 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -1,98 +1,280 @@ -{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, ParallelListComp, TupleSections #-} +{-# LANGUAGE ViewPatterns, ImplicitParams, NoMonomorphismRestriction, ParallelListComp, TupleSections, CPP, ForeignFunctionInterface, MultiParamTypeClasses, RankNTypes #-} +import Bindings.Posix.Sys.Mman +import Bindings.Posix.Unistd import Compile -import Context +import Context as C +import Control.Category ((>>>)) +import Data.ByteString.Internal import Data.ByteString.Unsafe +import Data.Functor.Identity +import Data.IORef import Data.List import Data.Maybe import Data.Ord import Data.Version -import qualified Data.Bimap as BM -import qualified Data.ByteString as B -import qualified Data.Map as M -import qualified Data.Serialize as Ser +import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) +import Foreign.C +import Foreign.ForeignPtr.Unsafe import Format -import Foreign hiding (void) +import ID import My.Control.Monad -import My.Control.Monad.State hiding ((<.>)) +import My.Control.Monad.State import My.Prelude import Options -import Paths_alpha (version) import PCode +import Paths_alpha (version) import Serialize import Specialize +import Specialize.Architecture import Syntax import Syntax.Parse -import System.IO import System.Directory import System.Environment as SE import System.FilePath +import System.IO +import System.IO.Unsafe (unsafePerformIO) import System.Posix.Files +import qualified Data.Bimap as BM +import qualified Data.ByteString as B +import qualified Data.Map as M +import qualified Data.Serialize as Ser +newtype Str = Str String +instance Show Str where show (Str s) = s + +withSettings :: ((?settings :: Settings) => IO a) -> IO a +withSettings m = gets settings >>= \s -> let ?settings = s in m + main = do args <- getArgs case getSettings args of - Right s -> execute s + Right s -> do + put (C s undefined undefined undefined undefined undefined) + withSettings $ case (action ?settings,programs ?settings) of + (PrintHelp,_) -> printHelp + (PrintVersion,_) -> printVersion + (Compile,[]) -> interactive + (Compile,progs) -> mapM_ compileProgram progs Left err -> fail err -execute s = case action s of - PrintHelp -> printHelp - PrintVersion -> printVersion - Compile -> doCompile s - printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++showVersion version -newtype Str = Str String -instance Show Str where show (Str s) = s +entry = formatEntry $ outputFmt ?settings +languageFile language = languageDir ?settingslanguage<.>"l" +findSource language = findM doesFileExist [dirlanguage<.>"a" | dir <- sourceDirs ?settings] -doCompile opts = case programs opts of - [] -> interactive - progs -> mapM_ compileProgram progs +interactive = withDefaultContext $ do + putStrLn $ "Alpha, version "++showVersion version++". Type alpha/help() for help on Alpha invocation. ^D to exit." + str <- getContents + let sTree = concat $ parseAlpha "/dev/stdin" str + mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (Group []:sTree) + putStrLn "\rGoodbye !" +compileProgram (language,entryName) = withDefaultContext $ do + importLanguage compileLanguage (const $ return ()) language + l <- getting language_ + entrySym <- viewState language_ $ internSym entryName + _ <- getAddressComp (outputArch ?settings) entrySym + (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses + top <- gets compTop + contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) + | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs] + writeFormat (outputFmt ?settings) entryName contents +compileLanguage force name = do + let langFile = languageFile name + source <- findSource name + skip <- return (not force) <&&> fileExist langFile <&&> maybe (return True) (langFile `newerThan`) source + l <- if skip then either (\e -> error $ "Error reading language file "++langFile++": "++e) + id $< Ser.decode $< B.readFile langFile else do + putStrLn $ "Compiling language "++name++"..." + lang <- compileFile $ fromMaybe (error $ "Couldn't find source file for language "++name) source + createDirectoryIfMissing True (dropFileName langFile) + B.writeFile langFile (Ser.encode lang) + return lang + return (not skip,l) + where compileFile src = withDefaultContext $ (>> gets language) $ do + str <- readFile src + let sTree = concat $ parseAlpha src str + init <- mapM compileExpr sTree + languageState $ modify $ \e -> exportLanguage $ e { initializeL = init } +compileExpr expr = do + symExpr <- languageState $ envCast expr + trExpr <- doTransform symExpr + (code,imports) <- languageState $ compile [] Nothing trExpr + mapM_ (importLanguage compileLanguage (mapM_ execCode)) imports + execCode code + return code + +foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt + +foreign import ccall "dynamic" mkProc :: FunPtr (Ptr() -> IO ()) -> Ptr() -> IO () +foreign import ccall "dynamic" mkFunSize :: FunPtr (Ptr() -> IO Int) -> Ptr() -> IO Int +foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO () +foreign import ccall "dynamic" mkFunTransform :: FunPtr (Ptr () -> Ptr() -> IO (Ptr ())) -> Ptr() -> Ptr () -> IO (Ptr ()) + +funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f +exportAlpha stub ptr = unsafePerformIO $ do + unsafeUseAsCStringLen (stub $ funPtrToInteger ptr) $ \(src,size) -> do + ptr <- mallocForeignPtrBytes size + withForeignPtr ptr $ \dst -> copyBytes (castPtr dst) src size + return ptr +initialBindings = [(n,Left $ Builtin b) | (b,n) <- bNames] ++ [ + ("alter" ,Left $ Axiom XAlter), + ("bind" ,Left $ Axiom XBind), + + ("choose" ,Left $ Axiom XChoose), + ("<-" ,Left $ Axiom XRestart), + ("->" ,Left $ Axiom XReturn), + ("do" ,Left $ Axiom XDo), + + ("lang" ,Left $ Axiom XLang), + ("verb" ,Left $ Axiom XVerb), + ("noun" ,Left $ Axiom XNoun), + + ("id" ,Left $ Axiom XID), + ("@" ,Left $ Axiom XAddr), + ("#" ,Left $ Axiom XSize)] ++ [ + + ("alpha/c@" , Right $ exportAlpha callStub1 alpha_compAddr), + ("alpha/create-symbol" , Right $ exportAlpha callStub0 alpha_createSym), + ("alpha/number-symbol" , Right $ exportAlpha callStub1 alpha_numSym), + ("alpha/symbol-name" , Right $ exportAlpha callStub1 alpha_symName), + ("alpha/name-symbol" , Right $ exportAlpha callStub1 alpha_nameSym), + + ("alpha/set-transform" , Right $ exportAlpha callStub1 alpha_setTransform), + ("alpha/reload" , Right $ exportAlpha callStub0 alpha_reload), + + ("alpha/allocate" , Right $ exportAlpha callStub1 alpha_allocate), + ("alpha/free" , Right $ exportAlpha callStub1 alpha_free), + + ("alpha/list" , Right $ exportAlpha callStub0 alpha_printList), + ("alpha/lang" , Right $ exportAlpha callStub0 alpha_printLang), + ("alpha/help" , Right $ exportAlpha callStub0 alpha_printHelp), + ("alpha/print-OK" , Right $ exportAlpha callStub0 alpha_printOK), + ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum) + ] + +#define str(x) #x +#define ALPHA_EXPORT(fun,t) foreign export ccall str(__alpha_##fun) __alpha_##fun :: t ; foreign import ccall str(&__alpha_##fun) alpha_##fun :: FunPtr (t) ; __alpha_##fun +ALPHA_EXPORT(setTransform,Ptr () -> IO ()) fun = modify $ \c -> c { transform = Just fun } +ALPHA_EXPORT(compAddr,ID -> IO Int) id = readIORef compAddrRef >>= ($id) + +ALPHA_EXPORT(symName,ID -> IO (Ptr Word8)) sym = do + n <- gets (lookupSymName sym . language) + ret <- newArray0 0 (map c2w $ fromMaybe "" n) + return ret +ALPHA_EXPORT(nameSym,Ptr Word8 -> IO ID) p = do + l <- peekArray0 0 p + viewState language_ (internSym $ map w2c l) +ALPHA_EXPORT(createSym,IO ID) = viewState language_ createSym +ALPHA_EXPORT(numSym,Int -> IO ID) = viewState language_ . internSym . show + +ALPHA_EXPORT(allocate,Int -> IO (Ptr())) = mallocBytes +ALPHA_EXPORT(free,Ptr() -> IO ()) = free + +ALPHA_EXPORT(printHelp,IO()) = printHelp +ALPHA_EXPORT(printOK,IO()) = putStrLn "OK" +ALPHA_EXPORT(printNum,Int -> IO()) n = print (intPtrToPtr $ fromIntegral n) +ALPHA_EXPORT(printList,IO()) = do + syms <- getting (language_ >>> syms_) + putStrLn $ intercalate " " (map fst $ BM.toList syms) +ALPHA_EXPORT(printLang,IO()) = getting language_ >>= print + +ALPHA_EXPORT(reload,IO()) = withSettings $ do + imports <- getting (language_ >>> f_ (languagesL >>> BM.toList >>> map fst)) + put initialContext + mapM_ (importLanguage compileLanguage (mapM_ execCode)) imports + +compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) +contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context) +instance MonadState Context IO where + get = readIORef contextRef + put = writeIORef contextRef + +initialContext = C ?settings lang jitA M.empty (fromIntegral entry) Nothing + where (lang,jitA) = execState (mapM_ st initialBindings) (C.emptyLanguage,M.empty) + where st (s,v) = do + i <- viewState fst_ (internSym s) + case v of + Left v -> modifying fst_ (setSymVal i v) + Right p -> modifying snd_ (M.insert i p) + +withDefaultContext = withState initialContext +contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a +languageState = contextState . viewing language_ + +pageSize = fromIntegral $ unsafePerformIO $ c'sysconf c'_SC_PAGESIZE +enableExec p size = do + let p' = alignPtr (p`plusPtr`(1-pageSize)) pageSize + mprotect (castPtr p') (fromIntegral $ size+ p`minusPtr`p') (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC) + +evalCode :: (FunPtr (Ptr() -> a) -> Ptr() -> a) -> ByteString -> Code -> (a -> IO b) -> IO b +evalCode wrap stub code f = do + sym <- languageState $ state createSym >>= \s -> modify (setSymVal s (Verb code)) >> return s + p <- getAddressJIT sym + unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) + +execCode c = evalCode mkProc execStub c id + +withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x +getAddress arch lookup register = withRef compAddrRef getAddr . getAddr where - entry = formatEntry $ outputFmt opts - languageFile language = languageDir optslanguage<.>"l" - findSource language = findM doesFileExist [file | dir <- sourceDirs opts - , let base = dirlanguage - , file <- [base<.>"a",base]] + getAddr sym = lookup sym >>= \val -> case val of + Just a -> return a + Nothing -> gets language >>= \lang -> (>> getAddr sym) $ case lookupSymVal sym lang of + Verb c -> void $ do + let (size,codem) = specialize arch (sym,getAddr) c + ptr <- mallocForeignPtrBytes size + register sym ptr size + code <- codem + withForeignPtr ptr $ \p -> do + unsafeUseAsCStringLen code $ \(p',n) -> copyBytes p (castPtr p') n + enableExec p size + Noun size init -> do + size <- evalCode mkFunSize execStub size id + ptr <- mallocForeignPtrBytes size + register sym ptr size + withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init ($castPtr p) + _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show sym) (lookupSymName sym lang) - interactive = withDefaultContext entry $ do - putStrLn $ "Alpha, version "++showVersion version++". Type alpha/help() for help on Alpha invocation. ^D to exit." - str <- getContents - let sTree = concat $ parseAlpha "/dev/stdin" str - mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (Group []:sTree) - putStrLn "\rGoodbye !" - compileProgram (language,entryName) = withDefaultContext entry $ do - importLanguage compileLanguage (const $ return ()) language - l <- getting language_ - entrySym <- viewState language_ $ internSym entryName - _ <- getAddressComp (outputArch opts) entrySym - (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses - top <- gets compTop - contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) - | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs] - writeFormat (outputFmt opts) entryName contents - compileLanguage force name = do - let langFile = languageFile name - source <- findSource name - skip <- return (not force) <&&> fileExist langFile <&&> maybe (return True) (langFile `newerThan`) source - l <- if skip then either (\e -> error $ "Error reading language file "++langFile++": "++e) - id $< Ser.decode $< B.readFile langFile else do - putStrLn $ "Compiling language "++name++"..." - lang <- compileFile $ fromMaybe (error $ "Couldn't find source file for language "++name) source - createDirectoryIfMissing True (dropFileName langFile) - B.writeFile langFile (Ser.encode lang) - return lang - return (not skip,l) - where compileFile src = withDefaultContext entry $ (>> gets language) $ do - str <- readFile src - let sTree = concat $ parseAlpha src str - init <- mapM compileExpr sTree - languageState $ modify $ \e -> exportLanguage $ e { initializeL = init } - compileExpr expr = do - symExpr <- languageState $ envCast expr - trExpr <- doTransform symExpr - (code,imports) <- languageState $ compile [] Nothing trExpr - mapM_ (importLanguage compileLanguage (mapM_ execCode . initializeL)) imports - execCode code - return code +getAddressJIT = getAddress arch_host lookup register + where lookup id = do + val <- M.lookup id $< gets jitAddresses + return $ (fromIntegral . ptrToIntPtr . unsafeForeignPtrToPtr) $< val + register id ptr size = modifying jitAddresses_ (M.insert id ptr) +getAddressComp arch = getAddress arch lookup register + where lookup id = (fst$<) $< M.lookup id $< gets compAddresses + register id ptr size = do + n <- getting compTop_ + modifying compAddresses_ (M.insert id (n,ptr)) + modifying compTop_ (+size) +doTransform syn = gets transform >>= ($syn) . maybe return tr + where tr fun tree = do + root <- allocTree tree + new <- unsafeUseAsCString initStub $ \stub -> mkFunTransform (castPtrToFunPtr stub) fun root + readTree new + intS = sizeOf (undefined::Int) ; ptrS = sizeOf (undefined::Ptr()) + pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e) + pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e) + allocTree (Group g) = do + p <- mallocBytes (intS+intS+(length g*ptrS)) + p' <- pok (0::Int) p + p'' <- pok (length g) p' + mapM allocTree g >>= \l -> pokeArray (castPtr p'') l + return p + allocTree (Symbol (ID s)) = do + p <- mallocBytes (intS+intS) + p' <- pok (1::Int) p + pok s p' + return p + readTree p = do + (t,p') <- pik p + case t :: Int of + 0 -> do + (s,p'') <- pik p' + l <- peekArray s p'' + liftM Group $ mapM readTree l + 1 -> do + liftM (Symbol . ID) $ peek p' + diff --git a/src/Compile.hs b/src/Compile.hs --- a/src/Compile.hs +++ b/src/Compile.hs @@ -3,7 +3,7 @@ import Compile.State as CS import Compile.Utils -import Context.Language +import Context import Data.Either import Data.Maybe import ID diff --git a/src/Compile/State.hs b/src/Compile/State.hs --- a/src/Compile/State.hs +++ b/src/Compile/State.hs @@ -1,6 +1,5 @@ {-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction, ViewPatterns #-} module Compile.State( - module Context.Types, module My.Data.Graph, CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..), depGraph_,infoStack_,imports_, @@ -26,11 +25,8 @@ import My.Control.Monad import ID import My.Data.Graph hiding (deleteEdge,deleteNode,getContext,empty) -import Context.Types -import Context.Language as L - +import Context as C import qualified My.Data.Graph as G -import qualified Context as E import qualified Data.Map as M deriving instance Eq Instruction @@ -63,7 +59,7 @@ isBackEdge (_,BranchAlt Backward _) = True isBackEdge _ = False -getSymName = lift . gets . L.lookupSymName +getSymName = lift . gets . C.lookupSymName getSymVal s = lift $ getting (vals_ >>> f_ (M.lookup s)) newVar = lift $ state createSym diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -1,203 +1,5 @@ -{-# LANGUAGE ForeignFunctionInterface, NoMonomorphismRestriction, MultiParamTypeClasses, CPP #-} module Context(module Context.Types - ,module Lang - ,withDefaultContext - ,languageState - ,doTransform ,getAddressComp - ,execCode) where + ,module Context.Language) where -import Bindings.Posix.Sys.Mman -import Bindings.Posix.Unistd -import Context.Language as Lang import Context.Types -import Control.Category ((>>>)) -import Data.ByteString.Internal -import Data.ByteString.Unsafe -import Data.Functor.Identity -import Data.IORef -import Data.List -import Data.Maybe -import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) -import Foreign.C -import Foreign.ForeignPtr.Unsafe -import Format -import ID -import My.Control.Monad -import My.Control.Monad.State -import My.Prelude -import Options -import PCode -import Specialize -import Specialize.Architecture -import Syntax -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Bimap as BM -import qualified Data.ByteString as B -import qualified Data.Map as M - -foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt - -foreign import ccall "dynamic" mkProc :: FunPtr (Ptr() -> IO ()) -> Ptr() -> IO () -foreign import ccall "dynamic" mkFunSize :: FunPtr (Ptr() -> IO Int) -> Ptr() -> IO Int -foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO () -foreign import ccall "dynamic" mkFunTransform :: FunPtr (Ptr () -> Ptr() -> IO (Ptr ())) -> Ptr() -> Ptr () -> IO (Ptr ()) - -funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f -exportAlpha stub ptr = unsafePerformIO $ do - unsafeUseAsCStringLen (stub $ funPtrToInteger ptr) $ \(src,size) -> do - ptr <- mallocForeignPtrBytes size - withForeignPtr ptr $ \dst -> copyBytes (castPtr dst) src size - return ptr -initialBindings = [(n,Left $ Builtin b) | (b,n) <- bNames] ++ [ - ("alter" ,Left $ Axiom XAlter), - ("bind" ,Left $ Axiom XBind), - - ("choose" ,Left $ Axiom XChoose), - ("<-" ,Left $ Axiom XRestart), - ("->" ,Left $ Axiom XReturn), - ("do" ,Left $ Axiom XDo), - - ("lang" ,Left $ Axiom XLang), - ("verb" ,Left $ Axiom XVerb), - ("noun" ,Left $ Axiom XNoun), - - ("id" ,Left $ Axiom XID), - ("@" ,Left $ Axiom XAddr), - ("#" ,Left $ Axiom XSize)] ++ [ - - ("alpha/c@" , Right $ exportAlpha callStub1 alpha_compAddr), - ("alpha/create-symbol" , Right $ exportAlpha callStub0 alpha_createSym), - ("alpha/number-symbol" , Right $ exportAlpha callStub1 alpha_numSym), - ("alpha/symbol-name" , Right $ exportAlpha callStub1 alpha_symName), - ("alpha/name-symbol" , Right $ exportAlpha callStub1 alpha_nameSym), - - ("alpha/set-transform" , Right $ exportAlpha callStub1 alpha_setTransform), - - ("alpha/allocate" , Right $ exportAlpha callStub1 alpha_allocate), - ("alpha/free" , Right $ exportAlpha callStub1 alpha_free), - - ("alpha/list" , Right $ exportAlpha callStub0 alpha_printList), - ("alpha/lang" , Right $ exportAlpha callStub0 alpha_printLang), - ("alpha/help" , Right $ exportAlpha callStub0 alpha_printHelp), - ("alpha/print-OK" , Right $ exportAlpha callStub0 alpha_printOK), - ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum) - ] - -#define str(x) #x -#define ALPHA_EXPORT(fun,t) foreign export ccall str(__alpha_##fun) __alpha_##fun :: t ; foreign import ccall str(&__alpha_##fun) alpha_##fun :: FunPtr (t) ; __alpha_##fun -ALPHA_EXPORT(setTransform,Ptr () -> IO ()) fun = modify $ \c -> c { transform = Just fun } -ALPHA_EXPORT(compAddr,ID -> IO Int) id = readIORef compAddrRef >>= ($id) - -ALPHA_EXPORT(symName,ID -> IO (Ptr Word8)) sym = do - n <- gets (lookupSymName sym . language) - ret <- newArray0 0 (map c2w $ fromMaybe "" n) - return ret -ALPHA_EXPORT(nameSym,Ptr Word8 -> IO ID) p = do - l <- peekArray0 0 p - viewState language_ (internSym $ map w2c l) -ALPHA_EXPORT(createSym,IO ID) = viewState language_ createSym -ALPHA_EXPORT(numSym,Int -> IO ID) = viewState language_ . internSym . show - -ALPHA_EXPORT(allocate,Int -> IO (Ptr())) = mallocBytes -ALPHA_EXPORT(free,Ptr() -> IO ()) = free - -ALPHA_EXPORT(printHelp,IO()) = Prelude.putStrLn helpMsg -ALPHA_EXPORT(printOK,IO()) = Prelude.putStrLn "OK" -ALPHA_EXPORT(printNum,Int -> IO()) n = print (intPtrToPtr $ fromIntegral n) -ALPHA_EXPORT(printList,IO()) = do - syms <- getting (language_ >>> syms_) - putStrLn $ intercalate " " (map fst $ BM.toList syms) -ALPHA_EXPORT(printLang,IO()) = getting language_ >>= print - -compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) -contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context) -instance MonadState Context IO where - get = readIORef contextRef - put = writeIORef contextRef - -initialContext entry = C lang jitA M.empty (fromIntegral entry) Nothing - where (lang,jitA) = execState (mapM_ st initialBindings) (Lang.empty,M.empty) - where st (s,v) = do - i <- viewState fst_ (internSym s) - case v of - Left v -> modifying fst_ (setSymVal i v) - Right p -> modifying snd_ (M.insert i p) - -withDefaultContext = withState . initialContext -contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a -languageState = contextState . viewing language_ - -pageSize = fromIntegral $ unsafePerformIO $ c'sysconf c'_SC_PAGESIZE -enableExec p size = do - let p' = alignPtr (p`plusPtr`(1-pageSize)) pageSize - mprotect (castPtr p') (fromIntegral $ size+ p`minusPtr`p') (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC) - -evalCode :: (FunPtr (Ptr() -> a) -> Ptr() -> a) -> ByteString -> Code -> (a -> IO b) -> IO b -evalCode wrap stub code f = do - id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i - p <- getAddressJIT id - unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) -execCode c = evalCode mkProc execStub c id - -withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x -getAddress arch lookup register = withRef compAddrRef getAddr . getAddr - where - getAddr sym = lookup sym >>= \val -> case val of - Just a -> return a - Nothing -> gets language >>= \lang -> (>> getAddr sym) $ case lookupSymVal sym lang of - Verb c -> void $ do - let (size,codem) = specialize arch (sym,getAddr) c - ptr <- mallocForeignPtrBytes size - register sym ptr size - code <- codem - withForeignPtr ptr $ \p -> do - unsafeUseAsCStringLen code $ \(p',n) -> copyBytes p (castPtr p') n - enableExec p size - Noun size init -> do - size <- evalCode mkFunSize execStub size id - ptr <- mallocForeignPtrBytes size - register sym ptr size - withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init ($castPtr p) - _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show sym) (lookupSymName sym lang) - -getAddressJIT = getAddress arch_host lookup register - where lookup id = do - val <- M.lookup id $< gets jitAddresses - return $ (fromIntegral . ptrToIntPtr . unsafeForeignPtrToPtr) $< val - register id ptr size = modifying jitAddresses_ (M.insert id ptr) -getAddressComp arch = getAddress arch lookup register - where lookup id = (fst$<) $< M.lookup id $< gets compAddresses - register id ptr size = do - n <- getting compTop_ - modifying compAddresses_ (M.insert id (n,ptr)) - modifying compTop_ (+size) - -doTransform syn = gets transform >>= ($syn) . maybe return tr - where tr fun tree = do - root <- allocTree tree - new <- unsafeUseAsCString initStub $ \stub -> mkFunTransform (castPtrToFunPtr stub) fun root - readTree new - intS = sizeOf (undefined::Int) ; ptrS = sizeOf (undefined::Ptr()) - pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e) - pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e) - allocTree (Group g) = do - p <- mallocBytes (intS+intS+(length g*ptrS)) - p' <- pok (0::Int) p - p'' <- pok (length g) p' - mapM allocTree g >>= \l -> pokeArray (castPtr p'') l - return p - allocTree (Symbol (ID s)) = do - p <- mallocBytes (intS+intS) - p' <- pok (1::Int) p - pok s p' - return p - readTree p = do - (t,p') <- pik p - case t :: Int of - 0 -> do - (s,p'') <- pik p' - l <- peekArray s p'' - liftM Group $ mapM readTree l - 1 -> do - liftM (Symbol . ID) $ peek p' - +import Context.Language diff --git a/src/Context/Language.hs b/src/Context/Language.hs --- a/src/Context/Language.hs +++ b/src/Context/Language.hs @@ -32,7 +32,7 @@ ["Exports: "++show (exportsL e)], ["Load code: "++show (initializeL e)]] -empty = Language (toEnum 0) BM.empty M.empty M.empty BM.empty M.empty S.empty [] +emptyLanguage = Language (toEnum 0) BM.empty M.empty M.empty BM.empty M.empty S.empty [] createSym e@(Language { maxIDL = m }) = (m,e { maxIDL = succ m }) setSymVal id v e = e { valuesL = M.insert id v (valuesL e) } @@ -66,8 +66,8 @@ mapM merge [imp | (imp,_) <- BM.toList (languagesL l')] return l' else return l' - mergeLanguage imp l' - loadImport l' + init <- mergeLanguage imp l' + loadImport init return $ comp || recomp mergeLanguage imp l' = viewing language_ $ do let Language { symbolsL = syms' , languagesL = mods' , maxIDL = mi' } = l' @@ -80,7 +80,7 @@ aliasesL = aliasesL l `M.union` M.fromList aliases, equivsL = equivsL l `M.union` M.fromList (map swap aliases) } - Language { aliasesL = al , languagesL = mods } <- get + Language { aliasesL = al , languagesL = mods, initializeL = init } <- get let tr s = fromMaybe (tr' s) $ M.lookup (tr' s) al tr' s' = fromMaybe (s' + mi) $ do m <- lookupSymMod s' l' @@ -93,6 +93,7 @@ valuesL = M.unionWith (\_ a -> a) (valuesL l) newVals, exportsL = exportsL l S.\\ M.keysSet newVals } + return (translate tr init) exportLanguage l = l { symbolsL = BM.filter exportNameP (symbolsL l), diff --git a/src/Context/Types.hs b/src/Context/Types.hs --- a/src/Context/Types.hs +++ b/src/Context/Types.hs @@ -10,6 +10,7 @@ import ID import PCode import Syntax +import Options data Axiom = XAlter | XBind | XReturn | XRestart | XChoose | XDo @@ -38,6 +39,7 @@ vals_ = View (valuesL,\v ce -> ce { valuesL = v }) data Context = C { + settings :: Settings, language :: Language, jitAddresses :: Map ID (ForeignPtr Word8), compAddresses :: Map ID (Int,ForeignPtr Word8), diff --git a/src/Format.hs b/src/Format.hs --- a/src/Format.hs +++ b/src/Format.hs @@ -27,11 +27,11 @@ let (+) = unionFileModes setFileMode name (ownerExecuteMode + groupExecuteMode + otherExecuteMode + fileMode stat) -#define importFun(fun,t) foreign import ccall #fun fun :: t -#define importFmt(fmt) importFun(fmt##_entry,Int) ; importFun(fmt##_headerSize,Int) ; importFun(fmt##_headerCons,Int -> IO (Ptr CChar)) ; fmt = F #fmt fmt##_entry fmt##_headerSize fmt##_headerCons +#define IMPORT_FUN(fun,t) foreign import ccall #fun fun :: t +#define IMPORT_FORMAT(fmt) IMPORT_FUN(fmt##_entry,Int) ; IMPORT_FUN(fmt##_headerSize,Int) ; IMPORT_FUN(fmt##_headerCons,Int -> IO (Ptr CChar)) ; fmt = F #fmt fmt##_entry fmt##_headerSize fmt##_headerCons raw entry = F ("raw:"++show entry) entry 0 (const $ return nullPtr) -importFmt(elf64) ; importFmt(elf32) ; importFmt(exe) +IMPORT_FORMAT(elf64) ; IMPORT_FORMAT(elf32) ; IMPORT_FORMAT(exe) formats = [elf64,elf32,exe] #if x86_64_HOST_ARCH diff --git a/src/PCode/Instruction.hs b/src/PCode/Instruction.hs --- a/src/PCode/Instruction.hs +++ b/src/PCode/Instruction.hs @@ -70,7 +70,7 @@ spanArray bs tree = array bs (assocs Nothing tree) where assocs p (Node a subs) = (a,(p,map rootLabel subs)):concatMap (assocs (Just a)) subs -codeRefs (Code args code ret) = [v | SymVal GValue v <- concatMap instrVals code] +codeRefs (Code args code ret) = [v | SymVal t v <- concatMap instrVals code, t == GValue || t==SymID] instance Show Instruction where show (Op BCall d (f:args)) = show d ++ " = " ++ show f ++ "(" ++ intercalate "," (map show args) ++ ")" diff --git a/src/PCode/Value.hs b/src/PCode/Value.hs --- a/src/PCode/Value.hs +++ b/src/PCode/Value.hs @@ -31,7 +31,7 @@ instance Show Value where show (SymVal t v) = prefix++show v - where prefix = fromJust $ lookup t [(Value,""),(Address,"@"),(Size,"#"),(SymID,"$"),(GValue,"")] + where prefix = fromJust $ lookup t [(Value,""),(Address,"@"),(Size,"#"),(SymID,"$"),(GValue,"g")] show (IntVal n) = show n show NullVal = "(null)" diff --git a/src/Specialize.hs b/src/Specialize.hs --- a/src/Specialize.hs +++ b/src/Specialize.hs @@ -110,18 +110,18 @@ , s <- S.toList $ clobbers i ref , s' <- bindSyms bv] next i r (Op BCall d (_:args)) = insertManyA r assocs - where assocs = [a | ref <- d : argRefs i args + where assocs = [a | ref <- S.toList (argsRefs i args) , v <- S.toList $ clobbers i ref , a <- [(v,worldID),(v,v)]] next _ r _ = r insertManyA r as = insertManyR r [a | (x,y) <- as, a <- [(x,y),(y,x)]] lookupRefs v r = ifEmpty (S.singleton worldID) $ R.lookupRan v r - argRefs i vs = S.toList $ S.fromList [s | SymVal Address s <- vs] + argsRefs i vs = S.fromList [s | SymVal Address s <- vs] <> S.unions [references i s | SymVal Value s <- vs] references i v = lookupRefs v (referencesA!i) - referencesA = treeArray next $ insertManyR R.empty [(s,worldID) | arg <- args, s <- bindSyms arg] - where next i r (Op _ v vs) = insertManyR r' (map (v,) $ argRefs i vs) - where r' = foldr (uncurry R.delete) r [(v,v') | v' <- S.toList $ R.lookupRan v r] + referencesA = treeArray next $ R.setDom worldID (S.fromList $ concatMap bindSyms args) R.empty + where next i r (Op b v vs) = R.setRan v (argsRefs i vs <> world) r + where world = if b==BCall then S.singleton worldID else S.empty next _ r _ = r ifEmpty def s | S.null s = def diff --git a/src/Specialize/Types.hs b/src/Specialize/Types.hs --- a/src/Specialize/Types.hs +++ b/src/Specialize/Types.hs @@ -2,7 +2,7 @@ module Specialize.Types(BinCode(..), isEmptyCode, binCodeData ,Architecture(..) ,Info(..) - ,Location(..), isFlags, regSyms, symLocs, symReg + ,Location(..), isFlags, isRegister, regSyms, symLocs, symReg ,MemState(..), Future(..), emptyFuture ,frame_, locations_, flocations_) where @@ -82,6 +82,7 @@ regNum (Register r) = Just r regNum _ = Nothing isFlags (Flags _) = True ; isFlags _ = False +isRegister (Register _) = True; isRegister _ = False regSyms r locs = S.toList $ R.lookupDom (Register r) locs symLocs s locs = S.toList $ R.lookupRan s locs diff --git a/src/Specialize/X86_64.hs b/src/Specialize/X86_64.hs --- a/src/Specialize/X86_64.hs +++ b/src/Specialize/X86_64.hs @@ -107,7 +107,8 @@ return r loadRoot Nothing = return rsp -saveRegs rs = lift locInfo >>= \(locs,_) -> saveVars $ concatMap (flip regSyms locs) rs +saveRegs rs = lift locInfo >>= \(locs,_) -> saveVars $ nubOrd $ concatMap (flip regSyms locs) rs +storeRegs rs = lift locInfo >>= \(locs,_) -> storeVars $ nubOrd $ concatMap (flip regSyms locs) rs saveVars = saveVars' (\p s -> R.member s Memory (locations p) || S.size (R.lookupRan s (locations p)) > 1) storeVars = saveVars' (\p s -> R.member s Memory (locations p)) saveVars' isSaved vs = lift locInfo >>= \(locs,_) -> do @@ -302,20 +303,21 @@ Nothing -> return () modify (SB.delete rax) - let args' = [(arg,Just r) | (id,arg) <- argAssocs, Register r <- symLocs id locs] + let args' = [(arg,Just r) | (sym,arg) <- argAssocs, Register r <- symLocs sym locs] (func:_,cload) <- listen $ loadArgs $ (fun,Nothing):args' readFuture $ do put (SB.empty compare) - (_,cstore) <- listen $ saveRegs allocRegs + (_,cstore) <- listen $ storeRegs allocRegs top <- lift $ gets (frameTop . frame) (_,cstore') <- listen $ do lift $ mapM_ (storeBig top) argAssocs subri rsp rsp $ Left (fi top) - let pos = verbAddress >§ (+(snd (instrAddress thisInstr)+delta)) + let pos = verbAddress >§ \va -> va+snd (instrAddress thisInstr)+delta BC ~(_,delta,_) = cload <> cstore <> cstore' (call <|||> calli pos) func addri rsp rsp $ Left (fi top) + lift $ modifying locations_ (R.filterRan (not . isRegister)) lift $ associateVR d rax compileOp b d [s]