alpha 1.0.2 → 1.0.5
raw patch · 17 files changed
+426/−326 lines, 17 filesdep +cpphs
Dependencies added: cpphs
Files
- alpha.cabal +5/−4
- src/Alpha.hs +6/−11
- src/Compile/State.hs +2/−2
- src/Compile/Utils.hs +1/−0
- src/Context.hs +82/−100
- src/Context/Language.hs +5/−5
- src/Elf.hs +0/−24
- src/Format.hs +44/−0
- src/My/Control/Monad/State.hs +5/−7
- src/My/Data/List.hs +11/−1
- src/Options.hs +20/−16
- src/Serialize.hs +1/−1
- src/Specialize/Architecture.hs +12/−14
- src/Specialize/X86_64.hs +66/−56
- src/Specialize/X86_64/Binary.hs +28/−20
- src/formats.c +138/−0
- src/writeElf.c +0/−65
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 1.0.2+version: 1.0.5 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@@ -20,10 +20,11 @@ location: git://github.com/lih/Alpha.git executable alpha- build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, AvlTree, COrdering+ build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, AvlTree, COrdering, cpphs main-is: Alpha.hs- other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Elf ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate+ other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Format ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate+ ghc-options: -pgmP cpphs -optP --hashes -optP --cpp hs-source-dirs: src- c-sources: src/writeElf.c+ c-sources: src/formats.c
src/Alpha.hs view
@@ -10,7 +10,7 @@ import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.Serialize as Ser-import Elf (writeElf,entryAddress)+import Format import Foreign hiding (void) import My.Control.Monad import My.Control.Monad.State hiding ((<.>))@@ -39,9 +39,6 @@ PrintVersion -> printVersion Compile -> doCompile s -formatEntry Elf64 = entryAddress-formatEntry (Raw n) = n- printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++showVersion version @@ -64,18 +61,16 @@ let sTree = concat $ parseAlpha "/dev/stdin" str mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (Group []:sTree) putStrLn "\rGoodbye !"- compileProgram (language,root) = withDefaultContext entry $ do+ compileProgram (language,entryName) = withDefaultContext entry $ do importLanguage compileLanguage (const $ return ()) language- l <- viewing language_ get- rootSym <- viewState language_ $ internSym root- getAddressComp (outputArch opts) rootSym+ 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]- case outputFmt opts of- Elf64 -> writeElf root contents- Raw _ -> B.writeFile root contents+ writeFormat (outputFmt opts) entryName contents compileLanguage force name = do let langFile = languageFile name source <- findSource name
src/Compile/State.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction, ViewPatterns #-} module Compile.State(- module Context, + module Context.Types, module My.Data.Graph, CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..), depGraph_,infoStack_,imports_,@@ -26,7 +26,7 @@ import My.Control.Monad import ID import My.Data.Graph hiding (deleteEdge,deleteNode,getContext,empty)-import Context+import Context.Types import Context.Language as L import qualified My.Data.Graph as G
src/Compile/Utils.hs view
@@ -3,6 +3,7 @@ import Control.Category ((>>>)) import Compile.State as CS+import Context.Language import Data.Array import Data.Function import Data.Maybe
src/Context.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE ForeignFunctionInterface, NoMonomorphismRestriction, MultiParamTypeClasses #-}+{-# LANGUAGE ForeignFunctionInterface, NoMonomorphismRestriction, MultiParamTypeClasses, CPP #-} module Context(module Context.Types- ,module Context.Language+ ,module Lang ,withDefaultContext ,languageState ,doTransform ,getAddressComp@@ -8,18 +8,19 @@ import Bindings.Posix.Sys.Mman import Bindings.Posix.Unistd-import Context.Language 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 Elf(entryAddress) 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@@ -30,6 +31,7 @@ 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 @@ -40,66 +42,12 @@ 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 ()) -withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f--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- 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--foreign export ccall "setTransform_" setTransform_ :: Ptr () -> IO ()-foreign import ccall "&setTransform_" setTransform_ptr :: FunPtr (Ptr () -> IO ())-setTransform_ fun = modify $ \c -> c { transform = Just fun }--foreign export ccall "compAddr_" compAddr_ :: ID -> IO Int-foreign import ccall "&compAddr_" compAddr_ptr :: FunPtr (ID -> IO Int)-compAddr_ id = readIORef compAddrRef >>= ($id)--foreign export ccall "symName_" symName_ :: ID -> IO (Ptr Word8)-foreign import ccall "&symName_" symName_ptr :: FunPtr (ID -> IO (Ptr Word8))-symName_ sym = do- n <- gets (lookupSymName sym . language)- ret <- newArray0 0 (map c2w $ fromMaybe "" n)- return ret-foreign export ccall "nameSym_" nameSym_ :: Ptr Word8 -> IO ID-foreign import ccall "&nameSym_" nameSym_ptr :: FunPtr (Ptr Word8 -> IO ID)-nameSym_ p = do- l <- peekArray0 0 p- viewState language_ (internSym $ map w2c l)-foreign export ccall "createSym_" createSym_ :: IO ID-foreign import ccall "&createSym_" createSym_ptr :: FunPtr (IO ID)-createSym_ = viewState language_ createSym-foreign export ccall "numSym_" numSym_ :: Int -> IO ID-foreign import ccall "&numSym_" numSym_ptr :: FunPtr (Int -> IO ID)-numSym_ = viewState language_ . internSym . show--foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ())-foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ()))-allocate_ = mallocBytes-foreign export ccall "free_" free_ :: Ptr() -> IO ()-foreign import ccall "&free_" free_ptr :: FunPtr (Ptr() -> IO ())-free_ = free--foreign export ccall "printHelp_" printHelp_ :: IO ()-foreign import ccall "&printHelp_" printHelp_ptr :: FunPtr (IO ())-printHelp_ = Prelude.putStrLn helpMsg-foreign export ccall "printOK_" printOK_ :: IO ()-foreign import ccall "&printOK_" printOK_ptr :: FunPtr (IO ())-printOK_ = Prelude.putStrLn "OK"-foreign export ccall "printNum_" printNum_ :: Int -> IO ()-foreign import ccall "&printNum_" printNum_ptr :: FunPtr (Int -> IO ())-printNum_ n = print (intPtrToPtr $ fromIntegral n)--- initialBindings = [(n,Left $ Builtin b) | (b,n) <- bNames] ++ [ ("alter" ,Left $ Axiom XAlter), ("bind" ,Left $ Axiom XBind),@@ -117,51 +65,56 @@ ("@" ,Left $ Axiom XAddr), ("#" ,Left $ Axiom XSize)] ++ [ - ("alpha/c@" , Right $ exportAlpha callStub1 compAddr_ptr), - ("alpha/create-symbol" , Right $ exportAlpha callStub0 createSym_ptr),- ("alpha/number-symbol" , Right $ exportAlpha callStub1 numSym_ptr),- ("alpha/symbol-name" , Right $ exportAlpha callStub1 symName_ptr),- ("alpha/name-symbol" , Right $ exportAlpha callStub1 nameSym_ptr),+ ("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 setTransform_ptr), + ("alpha/set-transform" , Right $ exportAlpha callStub1 alpha_setTransform), - ("alpha/allocate" , Right $ exportAlpha callStub1 allocate_ptr), - ("alpha/free" , Right $ exportAlpha callStub1 free_ptr), + ("alpha/allocate" , Right $ exportAlpha callStub1 alpha_allocate), + ("alpha/free" , Right $ exportAlpha callStub1 alpha_free), - ("alpha/help" , Right $ exportAlpha callStub1 printHelp_ptr),- ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), - ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr)+ ("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) ] -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'- +#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@@ -171,7 +124,6 @@ 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_ @@ -187,6 +139,7 @@ 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@@ -207,7 +160,7 @@ withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init ($castPtr p) _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show sym) (lookupSymName sym lang) -getAddressJIT = getAddress hostArch lookup register+getAddressJIT = getAddress arch_host lookup register where lookup id = do val <- M.lookup id $< gets jitAddresses return $ (fromIntegral . ptrToIntPtr . unsafeForeignPtrToPtr) $< val@@ -219,3 +172,32 @@ 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'+
src/Context/Language.hs view
@@ -94,17 +94,17 @@ exportsL = exportsL l S.\\ M.keysSet newVals } -exportLanguage e = e {- symbolsL = BM.filter exportNameP (symbolsL e),+exportLanguage l = l {+ symbolsL = BM.filter exportNameP (symbolsL l), valuesL = vals', aliasesL = M.empty, equivsL = M.empty, exportsL = S.empty,- initializeL = translate trans (initializeL e)+ initializeL = translate trans (initializeL l) } where set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined))- Language { exportsL = ex, equivsL = eqs } = e- vals' = M.map (translate trans) $ M.intersection (valuesL e) (set2Map ex)+ Language { exportsL = ex, equivsL = eqs } = l+ vals' = M.map (translate trans) $ M.intersection (valuesL l) (set2Map ex) trans s = fromMaybe s $ M.lookup s eqs refs = S.fromList $ concatMap references $ M.elems vals' exportNameP _ s = (S.member s ex || S.member s refs)
− src/Elf.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module Elf (writeElf,entryAddress) where--import Foreign-import Foreign.C-import System.Posix.IO-import System.Posix.Files-import Data.ByteString-import Data.ByteString.Unsafe--foreign import ccall "writeElf" - c_writeElf :: CInt -> Ptr CChar -> CInt -> IO ()-foreign import ccall "entryAddress"- entryAddress :: Int- -outFileMode = ownerModes + groupReadMode + groupExecuteMode + otherReadMode + otherExecuteMode- where (+) = unionFileModes- -writeElf :: String -> ByteString -> IO ()-writeElf name dat = do- fd <- createFile name outFileMode- unsafeUseAsCStringLen dat (\(d,nd) -> c_writeElf (fromIntegral fd) d (fromIntegral nd))- -
+ src/Format.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}+module Format where++import Foreign+import Foreign.C+import Foreign.Marshal.Alloc+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as BU+import Data.Monoid+import System.Posix.Files++data Format = F {+ formatName :: String,+ formatEntry :: Int,+ formatHeaderSize :: Int,+ formatHeaderCons :: Int -> IO (Ptr CChar)+ }++instance Show Format where+ show = formatName++writeFormat fmt name dat = do+ hp <- formatHeaderCons fmt (B.length dat)+ h <- BU.unsafePackCStringLen (hp,formatHeaderSize fmt)+ B.writeFile name (h <> dat)+ stat <- getFileStatus name+ 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++raw entry = F ("raw:"++show entry) entry 0 (const $ return nullPtr)+importFmt(elf64) ; importFmt(elf32) ; importFmt(exe)+formats = [elf64,elf32,exe]++#if x86_64_HOST_ARCH+defaultFormat = elf64+#else+defaultFormat = raw 0+#endif+++
src/My/Control/Monad/State.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE TupleSections, NoMonomorphismRestriction #-}-module My.Control.Monad.State(- module Control.Monad.State, - View(..),- viewState,viewing,modifying,getting,putting,- fst_,snd_,id_,f_,on_,- withState- ) where+module My.Control.Monad.State(module Control.Monad.State+ ,View(..)+ ,viewState,viewing,modifying,getting,putting+ ,fst_,snd_,id_,f_,on_+ ,withState) where import Prelude hiding ((.),id) import Control.Monad.State hiding (withState)
src/My/Data/List.hs view
@@ -1,4 +1,5 @@-module My.Data.List(module Data.List,classesBy,nubOrd,sums,zipRest) where+{-# LANGUAGE ParallelListComp #-}+module My.Data.List(module Data.List,classesBy,nubOrd,sums,zipRest,wrap) where import Data.List @@ -11,6 +12,15 @@ sums :: Num a => [a] -> [a] sums = scanl (+) 0++consume f [] = []+consume f l = let (a,t) = f l in a:consume f t++wrap words unwords n s = consume group $ words s+ where group ws = last [(unwords g,t)+ | g <- inits ws+ | t <- tails ws+ | sz <- map (subtract 1) $ sums (map ((1+) . length) ws), sz <= n] zipRest l l' = (zip l l',drop (length l) l')
src/Options.hs view
@@ -4,6 +4,7 @@ import System.Console.GetOpt import Data.Maybe import My.Data.List+import Format data Flag = Help | Version | SourceDir FilePath @@ -14,8 +15,6 @@ deriving Show data Action = PrintHelp | PrintVersion | Compile deriving Show-data Format = Elf64 | Raw Int- deriving Show data Settings = Settings { action :: Action, sourceDirs :: [FilePath],@@ -30,7 +29,8 @@ (a,':':b) -> a:splitArg b (a,"") -> [a] -options = ++options = map (\(Option a b c d) -> Option a b c (intercalate "\n" $ wrap words unwords 80 d)) [Option ['h','?'] ["help"] (NoArg Help) "prints usage information" ,Option ['v'] ["version"] (NoArg Version) @@ -42,24 +42,28 @@ "writes and seeks all language files in <dir> (defaults to the current directory)" ,sep ,Option ['a'] ["architecture"] (ReqArg (Architecture . str2arch) "<arch>") - $ "specializes for <arch> instead of the host architecture (<arch> can be one of "++foldr glue "" (tails archNames)++")"+ $ "specializes for <arch> instead of the host architecture (<arch> can be one of "++glue archNames++")" ,Option ['f'] ["format"] (ReqArg (Format . str2fmt) "<fmt>")- $ "writes the output programs in the specified format (<fmt> can be one of elf64 or \n"- ++"raw:<n> where <n> is the start address)"+ $ "writes the output programs in the specified format (<fmt> can be one of "++glue fmtNames++")" ]- where str2arch s = fromMaybe (error $ "Invalid architecture name "++s) $ lookup s $ zip archNames architectures- str2fmt s = case splitArg s of- ["elf64"] -> Elf64- ["raw",n] -> Raw (read n)- _ -> error ("Invalid format argument "++show s)+ where sep = Option [] [] undefined "-----------------" archNames = map archName architectures- glue [a] _ = a- glue [a,_] t = a++" or "++t- glue (a:_) t = a++", "++t- sep = Option [] [] undefined "-----------------"+ str2arch s = fromMaybe err $ lookup s [(archName a,a) | a <- architectures]+ where err = error $ "Invalid architecture name "++show s+ fmtNames = map formatName formats++["raw:<n> where <n> is the start address"]+ str2fmt s = case splitArg s of+ ["raw",n] -> raw (read n)+ [s] -> fromMaybe err $ lookup s [(formatName f,f) | f <- formats]+ _ -> err+ where err = error $ "Invalid format argument "++show s+ glue = foldr glue "" . tails+ where glue [a] _ = a+ glue [a,_] t = a++" or "++t+ glue (a:_) t = a++", "++t+ helpMsg = usageInfo "Usage: alpha <option>... <language>:<symbol>..." options -defaultSettings progs = Settings Compile ["."] "." (map readProg progs) hostArch Elf64+defaultSettings progs = Settings Compile ["."] "." (map readProg progs) arch_host defaultFormat where readProg p = case splitArg p of [l,s] -> (l,s) _ -> error $ "Ill-formed argument '"++p++"'. Should be of the form <language>:<symbol>"
src/Serialize.hs view
@@ -9,7 +9,7 @@ import Data.Bimap as BM import ID import PCode-import Context as C+import Context.Types as C deriving instance Generic ValType deriving instance Generic PCode.Value
src/Specialize/Architecture.hs view
@@ -1,27 +1,25 @@+{-# LANGUAGE CPP #-} module Specialize.Architecture(Architecture(..)- ,arch_x86- ,arch_x86_64- ,arch_arm- ,hostArch,Specialize.Architecture.execStub,Specialize.Architecture.initStub,Specialize.Architecture.callStub0,Specialize.Architecture.callStub1- ,architectures) where+ ,arch_host,arch_x86_64,architectures+ ,execStub,initStub,callStub0,callStub1) where import Specialize.Types-import Specialize.X86_64 as Host+import qualified Specialize.X86_64 as X86_64 import System.IO.Unsafe (unsafePerformIO)+#if x86_64_HOST_ARCH+import qualified Specialize.X86_64 as Host+#else+#error "Sorry, your architecture is not supported by Alpha just yet :-( "+#endif instance Eq Architecture where a == a' = archName a == archName a' instance Show Architecture where show a = "#<Arch:"++archName a++">" -undef s = error $ "undefined ("++s++")"--architectures = [hostArch,arch_x86_64]-nullArch = Arch undefined undefined (undef "initials") (undef "compile")-arch_x86 = nullArch { archName = "x86", archDefaultSize = 4 }-arch_arm = nullArch { archName = "arm", archDefaultSize = 4 }--hostArch = arch_x86_64 { archName = "host" }+architectures = [arch_host,arch_x86_64]+arch_host = Host.arch { archName = "host" }+arch_x86_64 = X86_64.arch execStub = unsafePerformIO Host.execStub initStub = unsafePerformIO Host.initStub
src/Specialize/X86_64.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ViewPatterns, TupleSections, ParallelListComp, ImplicitParams, NoMonomorphismRestriction #-}-module Specialize.X86_64(arch_x86_64,execStub,initStub,callStub0,callStub1) where+module Specialize.X86_64(arch,execStub,initStub,callStub0,callStub1) where import Control.Arrow import Control.Monad.Reader@@ -29,7 +29,7 @@ import qualified My.Data.Relation as R import qualified My.Data.SetBy as SB -arch_x86_64 = Arch "x86_64" defSize defaults compile+arch = Arch "x86-64" defSize defaults compile allocRegs = filter isAllocReg registers isAllocReg r = (r>=rax && r<rsp) || (r>rdi && r<=r15)@@ -40,10 +40,10 @@ a <|||> b = runKleisli (k a ||| k b) leftK f = runKleisli (left $ k f) -argVal (IntVal n) = Right $ withSize n-argVal (SymVal Size s) = Right $ withSize $ fromMaybe defSize $ M.lookup s (sizes ?info)-argVal (SymVal SymID (ID s)) = Right $ withSize $ s-argVal (SymVal GValue s) = Right (defSize*8,toInteger $< snd (envInfo ?info) s)+argVal (IntVal n) = Right $ Left n+argVal (SymVal Size s) = Right $ Left $ fi $ fromMaybe defSize $ M.lookup s (sizes ?info)+argVal (SymVal SymID (ID s)) = Right $ Left $ fi s+argVal (SymVal GValue s) = Right $ Right (defSize*8,toInteger $< snd (envInfo ?info) s) argVal (SymVal t s) = Left (t,s) valSym (SymVal Value s) = Just s valSym _ = Nothing@@ -241,7 +241,7 @@ Just f -> return f Nothing -> do [Left r] <- unReadFuture (loadArgs [(v,Nothing)])- cmpri r r (withSize (0 :: Int))+ cmpri r r (Left 0) return (Register r) [al,al'] <- mapM alignPast [def,null] let [_,_,p1,_,p2,_,p3] = scanl mappend (start thisInstr) codes@@ -252,12 +252,12 @@ mapM_ tell codes alts@(def:rest) -> readFuture $ do ([Left r],c) <- listen $ unReadFuture $ loadArgs [(v,Nothing)]- (_,c') <- listen $ cmpri r r (withSize (length alts))+ (_,c') <- listen $ cmpri r r (Left $ fi (length alts)) (alDef:alRest) <- mapM alignPast alts let codes = [jmpc [0x72] [0x0f,0x82] cmpP testP ,alDef <> jmp testP (start def) ,execWriter $ do- movi rsi (64,posAddr tableP)+ movi rsi (Right (64,posAddr tableP)) tellCode [fi $ fromFields [(0,1),(r`shiftR`3,1),(0x12,6)] ,0xff,0x24 ,fi $ fromFields [(0x6,3),(r.&.7,3),(0x3,2)]]@@ -311,59 +311,69 @@ top <- lift $ gets (frameTop . frame) (_,cstore') <- listen $ do lift $ mapM_ (storeBig top) argAssocs- subri rsp rsp $ withSize top+ subri rsp rsp $ Left (fi top) let pos = verbAddress >§ (+(snd (instrAddress thisInstr)+delta)) BC ~(_,delta,_) = cload <> cstore <> cstore' (call <|||> calli pos) func- addri rsp rsp $ withSize top+ addri rsp rsp $ Left (fi top) lift $ associateVR d rax -compileOp b d [s] | b`elem`[BSet,BSetSX,BNot,BSub] && varSize d<=defSize = withFreeSet $ do- [v] <- loadArgs [(s,Nothing)]- readFuture $ do- let dest r = maybe (destRegister d) (const $ return r) $ mfilter (not . isActive) $ valSym s- r' <- dest $ (id ||| const 0) v - (mov r' <|||> movi r') v- when (argSize s < varSize d) $ case () of- () | b`elem`[BSet,BNot] -> zxtnd r' (argSize s)- | b`elem`[BSetSX,BSub] -> sxtnd r' (argSize s)- case b of- BNot -> notr r'- BSub -> negr r'- _ -> doNothing- lift $ associateVar d (S.singleton (Register r'))+compileOp b d [s]+ | b`elem`[BSet,BSetSX,BNot,BSub] && varSize d<=defSize = withFreeSet $ do+ [v] <- loadArgs [(s,Nothing)]+ readFuture $ do+ let dest r = maybe (destRegister d) (const $ return r) $ mfilter (not . isActive) $ valSym s+ r' <- dest $ (id ||| const 0) v + (mov r' <|||> movi r') v+ when (argSize s < varSize d) $ case () of+ () | b`elem`[BSet,BNot] -> zxtnd r' (argSize s)+ | b`elem`[BSetSX,BSub] -> sxtnd r' (argSize s)+ case b of+ BNot -> notr r'+ BSub -> negr r'+ _ -> doNothing+ lift $ associateVar d (S.singleton (Register r')) -compileOp b d [a,a'] | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do- let ops = fromJust $ lookup b [(BAdd,(addrr,addri,addir,(+)))- ,(BSub,(subrr,subri,subir,(-)))- ,(BMul,(mulrr,mulri,mulir,(*)))- ,(BAnd,(bwandrr,bwandri,bwandir,(.&.)))- ,(BOr,(bworrr,bworri,bworir,(.|.)))- ,(BXor,(bwxorrr,bwxorri,bwxorir,xor))]- [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)]- readFuture $ do- dest <- destRegister d- opsCode ops dest v v'- lift $ associateVR d dest- | b`elem`[BLowerThan,BLowerEq,BEqual,BNotEqual,BGreaterEq,BGreaterThan] = withFreeSet $ do- let flag = fromJust (lookup b codes)- codes = [(BLowerThan,0xc),(BLowerEq,0xe),(BGreaterEq,0xf),(BGreaterThan,0xd),(BEqual,0x4),(BNotEqual,0x5)]- applys = [(BLowerThan,(<)),(BLowerEq,(<=)),(BGreaterEq,(>=)),(BGreaterThan,(>)),(BEqual,(==)),(BNotEqual,(/=))]- convert f n n' = if f n n' then 1 else 0- [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)]- readFuture $ do- opsCode (cmprr,cmpri,cmpir,convert $ fromJust (lookup b applys)) flag v v'- lift $ associateVL d (Flags flag)- | b`elem`[BMod,BDiv] = withFreeSet $ do- [_,_,v] <- loadArgs [(a,Just rax),(IntVal 0,Just rdx),(a',Nothing)]- readFuture $ do- case mfilter (/=d) $ valSym a of- Just s | isActive s -> saveRegs [rax]- _ -> return ()- case v of- Left r -> op [0xf7] 7 7 r- Right v -> opi (codeFun []) [0xf7] 7 7 v- lift $ associateVR d (if b==BMod then rdx else rax)+compileOp b d [a,a']+ | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do+ let ops = fromJust $ lookup b [(BAdd,(addrr,addri,addir,(+)))+ ,(BSub,(subrr,subri,subir,(-)))+ ,(BMul,(mulrr,mulri,mulir,(*)))+ ,(BAnd,(bwandrr,bwandri,bwandir,(.&.)))+ ,(BOr,(bworrr,bworri,bworir,(.|.)))+ ,(BXor,(bwxorrr,bwxorri,bwxorir,xor))]+ [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)]+ readFuture $ do+ dest <- destRegister d+ opsCode ops dest v v'+ lift $ associateVR d dest+ | b`elem`[BLowerThan,BLowerEq,BEqual,BNotEqual,BGreaterEq,BGreaterThan] = withFreeSet $ do+ let flag = fromJust (lookup b codes)+ codes = [(BLowerThan,0xc),(BLowerEq,0xe),(BGreaterEq,0xf),(BGreaterThan,0xd),(BEqual,0x4),(BNotEqual,0x5)]+ applys = [(BLowerThan,(<)),(BLowerEq,(<=)),(BGreaterEq,(>=)),(BGreaterThan,(>)),(BEqual,(==)),(BNotEqual,(/=))]+ convert f n n' = if f n n' then 1 else 0+ [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)]+ readFuture $ do+ opsCode (cmprr,cmpri,cmpir,convert $ fromJust (lookup b applys)) flag v v'+ lift $ associateVL d (Flags flag)+ | b`elem`[BMod,BDiv] && (const False ||| (isJust . log2n ||| const False)) (argVal a') = withFreeSet $ do+ [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)]+ readFuture $ do+ dest <- destRegister d+ let opri BMod dest r (Left n) = bwandri dest r (Left (n-1))+ opri BDiv dest r (Left n) = sari dest r (Left (fi $ fromJust $ log2n n))+ opsCode (undefined,opri b,undefined,if b==BMod then ((.&.) . (subtract 1)) else \n s -> shiftR n (fi s)) dest v v'+ lift $ associateVR d dest+ | b`elem`[BMod,BDiv] = withFreeSet $ do+ [_,_,v] <- loadArgs [(a,Just rax),(IntVal 0,Just rdx),(a',Nothing)]+ readFuture $ do+ case mfilter (/=d) $ valSym a of+ Just s | isActive s -> saveRegs [rax]+ _ -> return ()+ case v of+ Left r -> op [0xf7] 7 7 r+ Right v -> opi (codeFun []) [0xf7] 7 7 v+ lift $ associateVR d (if b==BMod then rdx else rax) compileOp b d args@(a:a':t) | isBinOp b = sequence_ [compileOp b d [a,a'] | b <- repeat b
src/Specialize/X86_64/Binary.hs view
@@ -16,7 +16,7 @@ bytes :: (Bits a,Integral a,Num b) => a -> [b] defSize :: Num a => a argBytesWide :: Bool -> Int -> Int -> (Maybe Integer) -> ([Word8],[Word8])-codeFun :: [(Int,(Word8,Int,Int))] -> (Int,IO Integer) -> Maybe (Word8,Int,Int,IO [Word8])+codeFun :: [(Int,(Word8,Int,Int))] -> Either Integer (Int,IO Integer) -> Maybe (Word8,Int,Int,IO [Word8]) fi = fromIntegral ; fis = fmap fromIntegral @@ -33,7 +33,7 @@ tellCode [0xc3] alphaStub loadArgs f = do loadArgs- movi rsi (withSize (f :: Integer))+ movi rsi (Left f) call rsi tellCode [0xc3] saved = rbx:rbp:[r12..r15]@@ -57,6 +57,8 @@ withSize n = (numSize n,return $ fi n) fromFields fs = foldl1 xor (zipWith shiftL (map (fst) fs) (scanl (+) 0 $ map snd fs)) bytes = fis . iterate (`shiftR`8)+log2n n = elemIndex n $ takeWhile (<=n) $ iterate (2*) 1+pow2 i = setBit 0 i fromBytesN n ml = BC (n,n,liftM B.pack ml) fromBytes c = fromBytesN (length c) (return c)@@ -83,13 +85,14 @@ where (pre,suf) = argBytes r d Nothing pref = pre++[code]++suf Nothing -> movi rsi n >> op def d a rsi-codeFun codes (size,n) = listToMaybe [(code,r,count,imm count) | (s,(code,count,r)) <- codes, s>=size]+codeFun codes val = listToMaybe [(code,r,count,imm count) | (s,(code,count,r)) <- codes, s>=size] where imm s = liftM (take s . bytes) n- + (size,n) = either withSize id val+ mov d s | d==s = return () | otherwise = tellCode (pre++[0x8b]++suf) where (pre,suf) = argBytes d s Nothing-movi d (0,_) = bwxorrr d d d+movi d (Left 0) = bwxorrr d d d movi d n = tell $ fromBytesN (length pref+s) (liftM (pref++) imm) where (code,r,s,imm) = fromJust $ codeFun [(31,(0xC7,4,0)),(64,(0xB8`xor`(fi d.&.7),8,0))] n (pre,suf) | code==0xC7 = argBytes 0 d Nothing@@ -101,24 +104,28 @@ 1 -> tellCode (pre++[0x0f,0xb6]++post) 2 -> tellCode (pre++[0x0f,0xb7]++post) _ -> shli r r sz >> shri r r sz- where sz = withSize $ 8*(defSize-s)+ where sz = Left (fi $ 8*defSize-s) where (pre,post) = argBytes r r Nothing sxtnd r s = case (s :: Int) of 1 -> tellCode (pre++[0x0f,0xbe]++post) 2 -> tellCode (pre++[0x0f,0xbf]++post) 4 -> tellCode (pre++[0x63]++post) _ -> shli r r sz >> sari r r sz- where sz = withSize $ 8*(defSize-s)+ where sz = Left (fi $ 8*defSize-s) where (pre,post) = argBytes r r Nothing setcc r f = tellCode (pre++[0x0f,0x90.|.fi f]++post) >> zxtnd r 1 where (pre,post) = argBytesWide False 0 r Nothing -shli = opi (codeFun [(8,(0xC1,1,4))]) undefined-shri = opi (codeFun [(8,(0xC1,1,5))]) undefined-sari = opi (codeFun [(8,(0xC1,1,7))]) undefined+withSpecial spe f d r (Left n) = fromMaybe (f d r (Left n)) $ spe d r n+withSpecial _ f d r v = f d r v+ignoreZero = const $ const $ flip lookup [(0,return ())]++shli = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,4))]) undefined+shri = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,5))]) undefined+sari = withSpecial ignoreZero $ opi (codeFun [(8,(0xC1,1,7))]) undefined rori d s n | n==0||n==64 = return ()- | otherwise = opi (codeFun [(8,(0xC1,1,1))]) undefined d s (withSize n)+ | otherwise = opi (codeFun [(8,(0xC1,1,1))]) undefined d s (Left n) ld d (_,_,0) = return () ld d (s,n,size) = load where szs = maximumBy (comparing weight) $ permutations [sz | sz <- [8,4,2,1], sz.&.size /= 0]@@ -133,7 +140,7 @@ ,(2,([0x66],[0x8b])) ,(1,([],[0x8a]))]) sh sz | fst||sz==8 = return ()- | otherwise = shli d d (withSize (sz*8))+ | otherwise = shli d d (Left (sz*8)) st (_,_,0) _ = return () st (d,n,size) s = store where szs = maximumBy (comparing weight) $ permutations [sz | sz <- [8,4,2,1], sz.&.size /= 0]@@ -153,10 +160,11 @@ commOp c c' = (op c,opn,flip . opn) where opn = opi (codeFun c') c -addri d r (0,_) = return ()-addri d r v = addri' d r v+addri = withSpecial ignoreZero addri' (addrr,addri',addir) = commOp [0x03] [(8,(0x83,1,0)),(32,(0x81,4,0))]-(mulrr,mulri,mulir) = commOp [0x0F,0xAF] [(8,(0x6B,1,0)),(64,(0x69,8,0))]+mulri = withSpecial spe mulri'+ where spe d r n = liftM (shli d r . Left . fi) $ log2n n+(mulrr,mulri',mulir) = commOp [0x0F,0xAF] [(8,(0x6B,1,0)),(64,(0x69,8,0))] (bwandrr,bwandri,bwandir) = commOp [0x23] [(7,(0x83,1,4)),(31,(0x81,4,4))] (bworrr,bworri,bworir) = commOp [0x0b] [(7,(0x83,1,1)),(31,(0x81,4,1))] (bwxorrr,bwxorri,bwxorir) = commOp [0x33] [(7,(0x83,1,6)),(31,(0x81,4,6))]@@ -166,8 +174,7 @@ where (pre,post) = argBytes 3 r Nothing subrr d a b | d==b = op [0x2b] d d a >> negr d | otherwise = op [0x2b] d a b-subri d r (0,_) = return ()-subri d r v = opi (codeFun [(8,(0x83,1,5)),(32,(0x81,4,5))]) [0x2b] d r v+subri = withSpecial ignoreZero $ opi (codeFun [(8,(0x83,1,5)),(32,(0x81,4,5))]) [0x2b] subir d n a | d==a = subri d d n >> negr d | otherwise = movi d n >> subrr d d a @@ -176,9 +183,8 @@ where codes = [(8,(0x83,1,7)),(32,(0x81,4,7))] cmpir _ n a = movi rsi n >> cmprr rsi rsi a -calli pos (size,v) = tell $ fromBytesN 5 $ do+calli pos (either withSize id -> (size,v)) = tell $ fromBytesN 5 $ do pos <- pos ; v <- v- -- putStrLn $ "calli: size="++show size++" pos="++show pos++" dest="++show v return $ [0xe8]++take 4 (bytes (v-fi pos-5)) call r = tellCode $ pre++[0xff]++post where (pre,post) = argBytesWide False 2 r Nothing@@ -187,5 +193,7 @@ (Left r,Left r') -> rr dest r r' (Left r,Right v) -> ri dest r v (Right v,Left r) -> ir dest v r- (Right (s,n),Right (s',n')) -> movi dest (min s s',liftM2 ii n n')+ (Right (Left n),Right (Left n')) -> movi dest (Left (ii n n'))+ (Right v,Right v') -> movi dest (Right (min s s',liftM2 ii n n'))+ where (s,n) = either withSize id v ; (s',n') = either withSize id v'
+ src/formats.c view
@@ -0,0 +1,138 @@+#include <libelf.h>+#include <stdlib.h>++typedef unsigned char byte;++#define SETSTRUCT(v,t,vals...) { t tmp = vals; v = tmp; }+#define DEF_FORMAT(fmt,base,htype,init...) \+ int const fmt##_HSIZE = sizeof(htype); \+ int const fmt##_ENTRY = sizeof(htype) + (base); \+ int fmt##_entry() { return fmt##_ENTRY; } \+ int fmt##_headerSize() { return fmt##_HSIZE; } \+ byte* fmt##_headerCons(int dataSize) { \+ htype* ret = malloc(sizeof(htype)); \+ SETSTRUCT(*ret,htype,init); \+ return (byte*)ret; \+ }++typedef struct {+ Elf64_Ehdr eh;+ Elf64_Phdr pht[1];+} elf64_Header;+DEF_FORMAT(elf64,1<<21,elf64_Header,{+ .eh = {+ .e_ident = { + ELFMAG0, ELFMAG1, ELFMAG2, ELFMAG3,+ ELFCLASS64, ELFDATA2LSB,+ EV_CURRENT,+ ELFOSABI_NONE, 0,+ 0+ },+ .e_type = ET_EXEC,+ .e_machine = EM_X86_64,+ .e_version = EV_CURRENT,+ .e_entry = elf64_ENTRY,+ .e_phoff = sizeof(Elf64_Ehdr),+ .e_shoff = 0,+ .e_flags = 0,+ .e_ehsize = sizeof(Elf64_Ehdr),+ .e_phentsize = sizeof(Elf64_Phdr),+ .e_phnum = 1,+ .e_shentsize = 0,+ .e_shnum = 0,+ .e_shstrndx = SHN_UNDEF+ },+ .pht = {{ + .p_type = PT_LOAD,+ .p_offset = elf64_HSIZE,+ .p_vaddr = elf64_ENTRY,+ .p_paddr = 0,+ .p_filesz = dataSize,+ .p_memsz = dataSize,+ .p_flags = PF_R | PF_W | PF_X,+ .p_align = 1<<21+ }}})++typedef struct {+ Elf32_Ehdr eh;+ Elf32_Phdr pht[1];+} elf32_Header;+DEF_FORMAT(elf32,1<<21,elf32_Header,{+ .eh = {+ .e_ident = { + ELFMAG0, ELFMAG1, ELFMAG2, ELFMAG3,+ ELFCLASS32, ELFDATA2LSB,+ EV_CURRENT,+ ELFOSABI_NONE, 0,+ 0+ },+ .e_type = ET_EXEC,+ .e_machine = EM_386,+ .e_version = EV_CURRENT,+ .e_entry = elf32_ENTRY,+ .e_phoff = sizeof(Elf32_Ehdr),+ .e_shoff = 0,+ .e_flags = 0,+ .e_ehsize = sizeof(Elf32_Ehdr),+ .e_phentsize = sizeof(Elf32_Phdr),+ .e_phnum = 1,+ .e_shentsize = 0,+ .e_shnum = 0,+ .e_shstrndx = SHN_UNDEF+ },+ .pht = {{ + .p_type = PT_LOAD,+ .p_offset = elf32_HSIZE,+ .p_vaddr = elf32_ENTRY,+ .p_paddr = 0,+ .p_filesz = dataSize,+ .p_memsz = dataSize,+ .p_flags = PF_R | PF_W | PF_X,+ .p_align = 1<<21+ }}})++typedef struct {+ unsigned short signature; /* == 0x5a4D */+ unsigned short bytes_in_last_block;+ unsigned short blocks_in_file;+ unsigned short num_relocs;+ unsigned short header_paragraphs;+ unsigned short min_extra_paragraphs;+ unsigned short max_extra_paragraphs;+ unsigned short ss;+ unsigned short sp;+ unsigned short checksum;+ unsigned short ip;+ unsigned short cs;+ unsigned short reloc_table_offset;+ unsigned short overlay_number;+} exe_Header;+DEF_FORMAT(exe,0x1000,exe_Header,{+ .signature = 0x5a4d,+ .bytes_in_last_block = (dataSize+exe_HSIZE)%512,+ .blocks_in_file = (dataSize+exe_HSIZE)/512,+ .num_relocs = 0,+ .header_paragraphs = 1,+ .min_extra_paragraphs = 0,+ .max_extra_paragraphs = 0,+ .ss = 0,+ .sp = 0x1000,+ .checksum = 0,+ .ip = exe_ENTRY,+ .cs = 0,+ .reloc_table_offset = 0,+ .overlay_number = 0+})++/* +Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com>+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++ Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+ Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/+
− src/writeElf.c
@@ -1,65 +0,0 @@-#include <unistd.h>-#include <libelf.h>--#define SETSTRUCT(v,t,vals...) { t tmp = vals; v = tmp; }-#define H_SIZE (sizeof(Elf64_Ehdr)+sizeof(Elf64_Phdr))-#define ENTRY (H_SIZE+(1<<21))--typedef unsigned char byte;--int entryAddress() { return ENTRY; }---void writeElf(int fd,byte* data,int dataSize) {- Elf64_Ehdr eh; Elf64_Phdr pht[1];-- SETSTRUCT(eh,Elf64_Ehdr,{- .e_ident = { - ELFMAG0, ELFMAG1, ELFMAG2, ELFMAG3,- ELFCLASS64, ELFDATA2LSB,- EV_CURRENT,- ELFOSABI_NONE, 0,- 0- },- .e_type = ET_EXEC,- .e_machine = EM_X86_64,- .e_version = EV_CURRENT,- .e_entry = ENTRY,- .e_phoff = sizeof(Elf64_Ehdr),- .e_shoff = 0,- .e_flags = 0,- .e_ehsize = sizeof(Elf64_Ehdr),- .e_phentsize = sizeof(Elf64_Phdr),- .e_phnum = 1,- .e_shentsize = 0,- .e_shnum = 0,- .e_shstrndx = SHN_UNDEF- });- SETSTRUCT(pht[0],Elf64_Phdr,{ - .p_type = PT_LOAD,- .p_offset = H_SIZE,- .p_vaddr = ENTRY,- .p_paddr = 0,- .p_filesz = dataSize,- .p_memsz = dataSize,- .p_flags = PF_R | PF_W | PF_X,- .p_align = 1<<21- });- - write(fd,&eh,sizeof(eh));- write(fd,&pht,sizeof(pht));- write(fd,data,dataSize);-}--/* -Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com>-All rights reserved.--Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-- Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.- Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/-