alpha 0.9.0.1 → 0.9.0.2
raw patch · 49 files changed
+1173/−1225 lines, 49 filesdep +transformersdep ~base
Dependencies added: transformers
Dependency ranges changed: base
Files
- alpha.cabal +4/−5
- src/Alpha.hs +58/−50
- src/Alpha/Elf.hs +0/−34
- src/Alpha/Options.hs +0/−76
- src/Alpha/writeElf.c +0/−71
- src/Compile.hs +31/−26
- src/Compile/State.hs +29/−27
- src/Compile/Utils.hs +27/−26
- src/Context.hs +124/−0
- src/Context/Language.hs +118/−0
- src/Context/Types.hs +51/−0
- src/Elf.hs +32/−0
- src/Environment.hs +0/−22
- src/Environment/Axiom.hs +0/−19
- src/Environment/Context.hs +0/−126
- src/Environment/Foreign.hs +0/−62
- src/Environment/Value.hs +0/−39
- src/ID.hs +42/−0
- src/IR.hs +0/−24
- src/IR/Builtin.hs +0/−25
- src/IR/Instruction.hs +0/−93
- src/IR/Value.hs +0/−47
- src/My/Control/Monad.hs +38/−0
- src/My/Control/Monad/State.hs +38/−0
- src/My/Control/Monad/TimeLine.hs +44/−0
- src/My/Data/Graph.hs +85/−0
- src/My/Data/List.hs +21/−0
- src/My/Prelude.hs +31/−0
- src/Options.hs +68/−0
- src/PCode.hs +19/−0
- src/PCode/Builtin.hs +25/−0
- src/PCode/Instruction.hs +105/−0
- src/PCode/Value.hs +47/−0
- src/Serialize.hs +13/−11
- src/Specialize.hs +8/−74
- src/Specialize/Architecture.hs +8/−21
- src/Specialize/Types.hs +12/−15
- src/Specialize/X86.hs +4/−0
- src/Syntax.hs +1/−3
- src/Syntax/Parse.hs +13/−10
- src/Translate.hs +17/−15
- src/Util/Graph.hs +0/−89
- src/Util/ID.hs +0/−35
- src/Util/List.hs +0/−21
- src/Util/Monad.hs +0/−33
- src/Util/Prelude.hs +0/−31
- src/Util/State.hs +0/−47
- src/Util/TimeLine.hs +0/−48
- src/writeElf.c +60/−0
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 0.9.0.1+version: 0.9.0.2 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,9 +20,8 @@ location: git://github.com/lih/Alpha.git executable alpha- build-depends: base<=4.5.1.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec+ build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers main-is: Alpha.hs- other-modules: Specialize.Types, Specialize.Architecture, IR.Builtin, IR.Instruction, IR.Value, IR, Serialize, Environment, Compile, Compile.State, Compile.Utils, Util.Prelude, Syntax.Parse, Translate, Specialize, Util.ID, Util.Monad, Util.TimeLine, Util.List, Util.Graph, Util.State, Environment.Axiom, Environment.Foreign, Environment.Value, Environment.Context, Syntax, Alpha.Elf, Alpha.Options+ other-modules: Alpha, Compile, Compile.State, Compile.Utils, Context, Context.Language, Context.Types, Elf, ID, My.Control.Monad, My.Control.Monad.State, My.Control.Monad.TimeLine, My.Data.Graph, My.Data.List, My.Prelude, Options, PCode, PCode.Builtin, PCode.Instruction, PCode.Value, Serialize, Specialize, Specialize.Architecture, Specialize.Types, Specialize.X86, Syntax, Syntax.Parse, Translate hs-source-dirs: src- c-sources: src/Alpha/writeElf.c-+ c-sources: src/writeElf.c
src/Alpha.hs view
@@ -1,24 +1,27 @@+{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction #-} import System.Environment as SE import System.FilePath import System.Directory import System.Posix.Files-import Alpha.Options-import Alpha.Elf (writeElf)+import Data.Ord+import Data.Maybe+import qualified Data.Map as M+import qualified Data.Bimap as BM+import qualified Data.Serialize as Ser+import qualified Data.ByteString as B+import Data.List+import My.Control.Monad+import My.Control.Monad.State hiding ((<.>))+import My.Prelude+import Options+import Elf (writeElf) import Syntax import Syntax.Parse-import Environment.Foreign as E-import Environment.Context import Compile-import Compile.State import Serialize-import Data.Serialize-import qualified Data.ByteString as B-import Data.Maybe-import Util.Monad-import Control.Monad.State-import Util.Prelude--- import Specialize-import IR+import Specialize+import Context+import PCode main = do args <- getArgs@@ -29,51 +32,56 @@ execute s = case action s of PrintHelp -> printHelp PrintVersion -> printVersion- Compile b -> print s >> doCompile b s+ Compile -> print s >> doCompile s +version = "0.9.0.2" printHelp = putStrLn helpMsg-printVersion = putStrLn "Alpha version 1.0"+printVersion = putStrLn $ "Alpha version "++version newtype Str = Str String instance Show Str where show (Str s) = s -doCompile interactive opts = if interactive then void $ compileFile "/dev/stdin" (runes opts)- else mapM_ compileRune (runes opts)- where - runeFile rune = runeDir opts</>rune<.>"r"- findScroll rune = findM fileExist (concat [[base,base<.>"a"] | dir <- scrollDirs opts, let base = dir</>rune])- compileFile src runes = withEnv defaultEnv $ (>>E.getEnv) $ do +doTestOlder = return True -- for testing purposes, turn makefile-style file dependencies on or off ++doCompile opts = case programs opts of + [] -> interactive+ progs -> mapM_ compileProgram progs+ where + languageFile language = languageDir opts</>language<.>"l"+ findSource language = findM fileExist (concat [[base,base<.>"a"] | dir <- sourceDirs opts+ , let base = dir</>language])+ readProg s = let (a,':':b) = break (==':') s in (a,b)+ + interactive = void $ compileFile "/dev/stdin" + compileProgram (readProg -> (language,root)) = withDefaultContext $ do+ importLanguage compileLanguage language+ rootSym <- stateF languageF $ internSym root+ getAddressComp (outputArch opts) rootSym+ chunks <- sortBy (comparing fst) $< M.elems $< gets compAddresses+ undefined+ compileLanguage name = do+ source <- fromMaybe (fail $ "Couldn't find source file for language "++name) $< findSource name+ let langFile = languageFile name+ b <- doTestOlder <&&> fileExist langFile <&&> (langFile `newerThan` source)+ if b then either error id $< Ser.decode $< B.readFile langFile else do + lang <- compileFile source+ createDirectoryIfMissing True (dropFileName langFile)+ B.writeFile langFile (Ser.encode lang)+ return lang+ loadLanguage name = compileLanguage name >>= execCode . loadCode >> languageState get+ + compileFile src = withDefaultContext $ (>> gets language) $ do str <- readFile src let sTree = concat $ parseAlpha src str- mapM_ doImport runes code <- mapM compileExpr sTree- stateEnv $ modify (\e -> e { load = foldr concatCode [] code })- compileRune name = do- scroll <- fromMaybe (error$"Couldn't find scroll file for rune "++name) $< findScroll name- let rune = runeFile name- ifM (fileExist rune <&&> (rune `newerThan` scroll)) - (putStrLn $ "Rune "++name++" already compiled. Skipping.") $ do - env <- compileFile scroll []- print env- createDirectoryIfMissing True (dropFileName rune)- B.writeFile rune (encode $ exportContext env)- compileExpr expr = do- (expr',env) <- envCast expr $< E.getEnv- (code,cenv) <- compile env Nothing $< doTransform expr'- print expr- setEnv (context cenv)- mapM_ doImport (imports cenv)- return code- doImport im = do - e <- E.getEnv- putStrLn $ "Importing rune "++im- unless (isImport im e) $ do - compileRune im- let rune = runeFile im- ce <- either error id $< decode $< B.readFile rune- print ce- mapM_ doImport (getImports ce)- e <- E.getEnv ; E.setEnv $ merge e (im,ce)+ languageState $ modify $ \e -> exportLanguage $ e { loadCode = foldr concatCode [] code }+ where compileExpr expr = print expr >> do+ symExpr <- languageState $ envCast expr+ trExpr <- doTransform symExpr+ (code,imports) <- languageState $ compile Nothing trExpr+ mapM_ (importLanguage loadLanguage) imports+ execCode code + return code -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com> -- All rights reserved.@@ -83,5 +91,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Alpha/Elf.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module Alpha.Elf (writeElf) where--import Foreign-import Foreign.C-import System.Posix.IO-import System.Posix.Files--foreign import ccall "writeElf" - c_writeElf :: CInt -> Ptr CUChar -> CInt -> Ptr CUChar -> CInt -> IO ()- --outFileMode = ownerModes + groupReadMode + groupExecuteMode + otherReadMode + otherExecuteMode- where (+) = unionFileModes- -writeElf :: String -> [Word8] -> [Word8] -> IO ()-writeElf name c d = do- fd <- createFile name outFileMode- withArrayLen (map fromIntegral c) - (\nc c -> withArrayLen (map fromIntegral d) - (\nd d ->- c_writeElf (fromIntegral fd) c (fromIntegral nc) d (fromIntegral nd)))- ---- 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/Alpha/Options.hs
@@ -1,76 +0,0 @@-module Alpha.Options (Architecture(..),Action(..),Settings(..),helpMsg,getSettings) where--import Specialize.Architecture-import System.Console.GetOpt-import Data.Maybe-import Util.List--data Flag = Help | Version | Interactive - | Scroll FilePath - | Spell FilePath - | Rune FilePath - | SpellArch Architecture - deriving Show-data Action = PrintHelp | PrintVersion | Compile Bool- deriving Show--data Settings = Settings {- action :: Action,- scrollDirs :: [FilePath],- runeDir :: FilePath,- spellFile :: FilePath,- outputArch :: Architecture,- runes :: [FilePath]- }- deriving Show--options = [- Option ['h'] ["help"] (NoArg Help) - "prints usage information",- Option ['v'] ["version"] (NoArg Version) - "prints Alpha's version information",- Option ['i'] ["interactive"] (NoArg Interactive)- "starts Alpha in interactive mode",- sep,- Option ['S'] ["scroll-dir"] (ReqArg Scroll "DIR") - "adds DIR to the list of directories searched for scrolls",- Option ['R'] ["rune-dir"] (ReqArg Rune "DIR") - "casts all runes in DIR (default '.')",- sep,- Option ['s'] ["spell-file"] (ReqArg Spell "FILE") - "writes spell into FILE (default is '/dev/null')",- Option ['a'] ["architecture"] (ReqArg (SpellArch . str2arch) "ARCH") - $ "specializes for ARCH instead of the local architecture (ARCH is one of "++foldr glue "" (tails archNames)++")"- ]- where str2arch s = fromMaybe (error $ "Invalid architecture name "++s) $ lookup s $ zip archNames architectures- archNames = map archName architectures- glue [a] _ = a- glue [a,_] t = a++" or "++t- glue (a:_) t = a++", "++t- sep = Option [] [] undefined "-----------------"-helpMsg = usageInfo "Usage: Alpha <options> <files>" options--defaultSettings mods = Settings (Compile False) ["."] "." "/dev/null" hostArch mods-getSettings [] = Right $ (defaultSettings []) { action = PrintHelp }-getSettings args = case getOpt Permute options args of- (opts,mods,[]) -> Right $ foldl handleOpt (defaultSettings mods) opts- (_,_,err) -> Left $ helpMsg ++ concatMap ("\n"++) err- where handleOpt s Help = s { action = PrintHelp }- handleOpt s Version = s { action = PrintVersion }- handleOpt s Interactive = s { action = Compile True }- handleOpt s (Scroll d) = s { scrollDirs = d : scrollDirs s }- handleOpt s (Spell f) = s { spellFile = f }- handleOpt s (Rune f) = s { runeDir = f }- handleOpt s (SpellArch a) = s { outputArch = a }----- 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/Alpha/writeElf.c
@@ -1,71 +0,0 @@-#include <unistd.h>-#include <libelf.h>-#include "writeElf.h"--void writeElf(int fd,byte* code,int codeSize,byte* data,int dataSize) {- unsigned int hSize = sizeof(Elf64_Ehdr) + 2*sizeof(Elf64_Phdr);- unsigned int entry = (1<<21) + hSize;-- Elf64_Ehdr 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 = entry,- .e_phoff = sizeof(Elf64_Ehdr),- .e_shoff = 0,- .e_flags = 0,- .e_ehsize = sizeof(Elf64_Ehdr),- .e_phentsize = sizeof(Elf64_Phdr),- .e_phnum = 2,- .e_shentsize = 0,- .e_shnum = 0,- .e_shstrndx = SHN_UNDEF- };- Elf64_Phdr pht[2] = {- {- .p_type = PT_LOAD,- .p_offset = hSize,- .p_vaddr = entry,- .p_paddr = entry,- .p_filesz = codeSize,- .p_memsz = codeSize,- .p_flags = PF_R | PF_X,- .p_align = 1<<21- },- {- .p_type = PT_LOAD,- .p_offset = hSize+codeSize,- .p_vaddr = entry+codeSize,- .p_paddr = entry+codeSize,- .p_filesz = dataSize,- .p_memsz = dataSize,- .p_flags = PF_R | PF_W | PF_X,- .p_align = 1- }- };- - write(fd,&eh,sizeof(eh));- write(fd,&pht,sizeof(pht));- write(fd,code,codeSize);- 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. -*/-
src/Compile.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE TupleSections, ParallelListComp #-}+{-# LANGUAGE TupleSections, ParallelListComp, NoMonomorphismRestriction #-} module Compile(compile) where import Debug.Trace -import Compile.Utils--import Compile.State as CS-import IR-import Util.Prelude-import Util.ID-import Util.Graph as G hiding (deleteEdge,deleteNode)-import Util.State-import Util.Monad-import Util.List-import Syntax+import My.Prelude+import My.Data.Graph as G hiding (deleteEdge,deleteNode)+import My.Data.List+import My.Control.Monad.State+import My.Control.Monad import Data.Maybe import Data.Either+import PCode+import Context.Language+import Syntax+import ID+import Compile.Utils+import Compile.State as CS -compile env dest expr = runState st (defaultState env)+compile dest expr = runStateT st defaultState >§ \(code,cs) -> (code,imports cs) where st = do (_,(start,_)) <- compile' dest expr simplify start >>= linearize@@ -31,7 +31,7 @@ guard (not $ v `varEqVal` val) return $ do n <- createNode (Instr $ set v val) return (def,singleCode n)-compile' dest (Group expr@(Symbol id:args)) = do+compile' dest (Group (Symbol id:args)) = do gl <- getSymVal id let compile = case gl of Just (Axiom a) -> compileAxiom a@@ -59,10 +59,10 @@ where doBind' bVars compile = compile *>>= \v -> do bnd <- bindFromSyntax bVars- n <- createNode (Instr $ IR.Bind bnd v)+ n <- createNode (Instr $ PCode.Bind bnd v) return (NullVal,singleCode n) doBind [bVars] = doBind' bVars $ nullCode- doBind [bVars,expr] = doBind' bVars $ compile' Nothing expr+ doBind [bVars,expr] = doBind' bVars $ newVar >>= \v -> compile' (Just v) expr compileAxiom XDo dest [] = nullCode compileAxiom XDo dest forms = do @@ -94,17 +94,18 @@ compileAxiom XVerb dest [Group (name:args),expr] = do bindArgs <- mapM bindFromSyntax args (sym,ret,code) <- compileBody name expr- modifyF envF $ exportSymVal sym (Verb bindArgs ret code)+ lift $ modify $ exportSymVal sym (Verb (Code bindArgs code ret)) compile' dest (Symbol sym) compileAxiom XVerb dest [Symbol s,Symbol a] = do- modifyF envF $ \env -> exportSymVal s (lookupSymVal a env) env+ lift $ modify $ \env -> exportSymVal s (lookupSymVal a env) env compile' dest (Symbol s)-compileAxiom XNoun dest [name,init] = do- (sym,ret,code) <- compileBody name init- modifyF envF $ exportSymVal sym (Noun ret code)+compileAxiom XNoun dest [Symbol sym,size,init] = do+ (retSz,codeSz) <- compileExpr size+ (retInit,codeInit) <- compileExpr init+ lift $ modify $ exportSymVal sym $ Noun (Code [] codeSz (symBind retSz)) (Code [symBind sym] codeInit (symBind retInit)) compile' dest (Symbol sym) -compileAxiom XRune _ [Symbol s] = do+compileAxiom XLang _ [Symbol s] = do getSymName s >>= maybe (return()) (modify . (\n e -> e { imports = n:imports e })) nullCode @@ -114,10 +115,14 @@ compileAxiom a _ args = error $ "Couldn't compile axiom "++show a++" with args "++show args -compileBody retBind body = do+compileExpr expr = do ret <- newVar+ (code,imps) <- lift $ compile (Just ret) expr+ modifyF importsF (imps++)+ return (ret,code)+compileBody retBind body = do bv <- bindFromSyntax retBind- code <- stateF envF $ \env -> let (c,st) = compile env (Just ret) body in (c,context st)+ (ret,code) <- compileExpr body return (bindSym bv,bv { bindSym = ret },code) compileValue dest val = do c <- singleCode $< case dest of@@ -125,7 +130,7 @@ Nothing -> mkNoop return (val,c) -bindFromSyntax (Symbol v) = return $ BindVar v (0,1) 0 []+bindFromSyntax (Symbol v) = return $ symBind v bindFromSyntax (Group (Symbol v:t)) = do let fun (ns,l) (Symbol v) = getSymName v >>= \s -> maybe (fun' ns l (Symbol v)) (\n -> return (n:ns,l)) (readConstant =<< s)@@ -149,5 +154,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Compile/State.hs view
@@ -1,15 +1,16 @@+{-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction #-} module Compile.State(- module Environment, - module Util.Graph,+ module Context, + module My.Data.Graph, CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..),- envF,depGraphF,infoStackF,+ depGraphF,infoStackF,importsF, newVar, pushInfo,popInfo,topInfo,withInfo,withTopInfo, defaultState, getSymName,getSymVal, singleCode, isBackEdge,- getNodeList,getContext,+ getNodeList,getLanguage, createEdge,deleteEdge, createNode,deleteNode, nullCode,nullCodeVal,@@ -18,50 +19,51 @@ ) where -import IR-import Util.State-import Util.Monad-import Util.ID-import Util.Graph hiding (deleteEdge,deleteNode,getContext,Context,empty)-import Environment hiding(lookupSymName)+import PCode+import My.Control.Monad.State+import My.Control.Monad+import ID+import My.Data.Graph hiding (deleteEdge,deleteNode,getLanguage,Language,empty)+import Context+import Context.Language as L -import qualified Util.Graph as G-import qualified Environment as E+import qualified My.Data.Graph as G+import qualified Context as E import qualified Data.Map as M +deriving instance Eq Instruction+deriving instance Eq PCode.Value+deriving instance Eq BindVar+ data BranchType = Forward | Backward deriving (Show,Eq) data EdgeData = BranchAlt BranchType Int | TimeDep deriving (Show,Eq) data NodeData = Instr Instruction- | BrPart IR.Value+ | BrPart PCode.Value+ deriving Eq type CaseInfo = (Node,[Node],Node,Maybe ID) data CompileState = CS {- context :: Context, infoStack :: [CaseInfo], imports :: [String], depGraph :: Graph EdgeData NodeData } deriving Show -getSymName :: ID -> State CompileState (Maybe String)-getNodeList :: State CompileState [Node]-getContext :: Node -> State CompileState (G.Context EdgeData NodeData)--envF = (context,\e cs -> cs { context = e })-depGraphF = (depGraph,(\g cs -> cs { depGraph = g }))-infoStackF = (infoStack,(\l cs -> cs { infoStack = l }))+depGraphF = Field (depGraph,(\g cs -> cs { depGraph = g }))+infoStackF = Field (infoStack,(\l cs -> cs { infoStack = l }))+importsF = Field (imports,(\l cs -> cs { imports = l })) -defaultState env = CS env [] [] G.empty+defaultState = CS [] [] G.empty singleCode n = ([n],[n]) isBackEdge (_,BranchAlt Backward _) = True isBackEdge _ = False -getSymName = getsF envF . E.lookupSymName-getSymVal = getsF (envF <.> valsF) . M.lookup-newVar = stateF envF createSym+getSymName = lift . gets . L.lookupSymName+getSymVal s = lift $ getsF valsF $ M.lookup s+newVar = lift $ state createSym pushInfo = modifyF infoStackF . (:) popInfo = stateF infoStackF (\(h:t) -> (h,t))@@ -74,7 +76,7 @@ nullCodeVal v = mkNoop >>= \n -> return (v,singleCode n) getNodeList = getsF depGraphF nodeList-getContext n = getsF depGraphF (G.getContext n)+getLanguage n = getsF depGraphF (G.getLanguage n) createNode x = stateF depGraphF (G.insertNode x) deleteNode n = modifyF depGraphF (G.deleteNode n)@@ -119,5 +121,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Compile/Utils.hs view
@@ -1,22 +1,23 @@-{-# LANGUAGE TupleSections, ViewPatterns #-}+{-# LANGUAGE TupleSections, ViewPatterns, NoMonomorphismRestriction #-} module Compile.Utils where import Compile.State as CS-import qualified Util.Graph as G-import Util.Prelude-import Util.Monad-import Util.State-import Util.List+import qualified My.Data.Graph as G+import My.Prelude+import My.Control.Monad+import My.Control.Monad.State+import My.Data.List import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe-import IR+import PCode import Syntax import Debug.Trace +simplify :: Monad m => [Node] -> StateT CompileState m [Node] simplify start = do oldDep <- getF depGraphF ; purgeAll ; newDep <- getF depGraphF return $ concatMap (newStart oldDep newDep) start@@ -25,9 +26,9 @@ mapM_ (purgeNode isNoop) =<< getNodeList mapM_ (purgeNode isEmptyBranch) =<< getNodeList purgeNode p n = do- c <- getContext n + c <- getLanguage n if p c then remove (n,c) else return ()- isNoop c = case tag c of Instr Noop -> True ; _ -> False+ isNoop c = tag c==Instr Noop isEmptyBranch c = case tag c of BrPart _ -> not (null o) && all p i && all p' o _ -> False@@ -50,9 +51,9 @@ where newStart n = maybe (maybe [] (\c -> concat [newStart n | (n,_) <- outEdges c])- (lookupContext n old)) + (lookupLanguage n old)) (const [n])- (lookupContext n new)+ (lookupLanguage n new) data ANode = ANode { weight :: Int,@@ -64,15 +65,15 @@ linearize' start depG = instrs where aG = annotate depG- getContext n = G.getContext n aG- withContext n = (n,getContext n)+ getLanguage n = G.getLanguage n aG+ withLanguage n = (n,getLanguage n) - isBrPart (instr . tag . getContext -> BrPart _) = True+ isBrPart (instr . tag . getLanguage -> BrPart _) = True isBrPart _ = False instrMap = M.fromList [(n,i) | (i,(n,_)) <- zip [0..] $ concat [map (n,) (getInstr n) | n <- concat blocks]] instrs = concatMap (concatMap getInstr) blocks - getInstr (getContext -> c) = case tag c of+ getInstr (getLanguage -> c) = case tag c of ANode { instr = BrPart v } -> [Branch v $ map branch (classesBy (===) oes)] where branch ns = minimum $ catMaybes [M.lookup n instrMap | (n,_) <- ns] (_,e) === (_,e') = e==e'@@ -80,17 +81,17 @@ where oes = outEdges c selectHeads l = [n | (n,c) <- l, weight (tag c)==1]- startHeads = selectHeads $ map withContext $ nub start+ startHeads = selectHeads $ map withLanguage $ nub start heads = startHeads : deleteBy headsEq startHeads heads where eq n1 n2 = if n1`elem`start then n2`elem`start else c'- where c' = n2 `elem` [n | (n,e') <- outEdges $ getContext prev, e==e']- (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG) $ find isBackEdge $ inEdges $ getContext n1+ where c' = n2 `elem` [n | (n,e') <- outEdges $ getLanguage prev, e==e']+ (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG) $ find isBackEdge $ inEdges $ getLanguage n1 headsEq a b = sort a==sort b heads = classesBy eq $ selectHeads $ nodeListFull aG tails = map (nub . concatMap saturate) heads saturate n = if null nexts then [n] else concatMap saturate nexts- where nexts = [n' | let c = getContext n - , (n',c') <- map withContext $ nextNodes c+ where nexts = [n' | let c = getLanguage n + , (n',c') <- map withLanguage $ nextNodes c , weight (tag c') > weight (tag c)] blocks = map blockFromTails tails@@ -102,21 +103,21 @@ prevs <- mapM makeBlock (getPrevs n) visit n return $ concat prevs ++ [n]- getPrevs n = map fst $ sortBy cmp $ filter p $ map withContext $ prevNodes context+ getPrevs n = map fst $ sortBy cmp $ filter p $ map withLanguage $ prevNodes language where cmp (_,c) (_,c') = compare (erNum $ tag c') (erNum $ tag c)- p (_,c) = weight (tag c) < weight (tag context)- context = getContext n+ p (_,c) = weight (tag c) < weight (tag language)+ language = getLanguage n annotate depG = newdepG where newdepG = mapNodes depCalc depG depCalc (depCalc' -> (a,b)) i = ANode a b i- depCalc' (flip G.getContext depG -> c)+ depCalc' (flip G.getLanguage depG -> c) | any isBackEdge <||> null $ inEdges c = (1,1) | otherwise = (1+maximum a, maximum $ zipWith (+) [0..] (reverse $ sort b)) where (a,b) = unzip [(weight t,erNum t) | n' <- prevNodes c- , let t = tag $ G.getContext n' newdepG]+ , let t = tag $ G.getLanguage n' newdepG] maximum = foldl max 0 @@ -130,5 +131,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Context.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ForeignFunctionInterface, NoMonomorphismRestriction, MultiParamTypeClasses #-}+module Context(module Context.Types+ ,module Context.Language+ ,withDefaultContext+ ,languageState+ ,doTransform ,getAddressComp+ ,execCode) where++import System.IO.Unsafe (unsafePerformIO)+import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr)+import Foreign.ForeignPtr.Unsafe+import Data.Maybe+import Data.ByteString.Unsafe+import qualified Data.Map as M+import Data.Functor.Identity+import Data.IORef+import My.Control.Monad+import My.Control.Monad.State++import Context.Types+import Context.Language+import Specialize+import PCode+import ID+import Syntax+import Specialize.Architecture++withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x++contextRef = unsafePerformIO $ newIORef (undefined :: Context)+instance MonadState Context IO where+ get = readIORef contextRef+ put = writeIORef contextRef++addressRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int)+foreign export ccall "address_" address_ :: ID -> IO Int+address_ i = readIORef addressRef >>= ($i)+foreign import ccall "&address_" address_ptr :: FunPtr (ID -> IO Int)++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)] ++ [+ ("addressC",Right $ castFunPtrToPtr address_ptr)+ ]++doTransform syn = gets transform >>= ($syn)++initialContext = C lang jitA M.empty 0 return+ where (lang,jitA) = execState (mapM_ st initialBindings) (empty,M.empty)+ where st (s,v) = do+ i <- stateF fstF (internSym s) + case v of+ Left v -> modifyF fstF (setSymVal i v)+ Right p -> modifyF sndF (M.insert i $ unsafePerformIO $ newForeignPtr_ p)++withDefaultContext = withState initialContext++contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a+languageState = contextState . doF languageF++foreign import ccall "dynamic" mkProc :: FunPtr (IO ()) -> IO ()+foreign import ccall "dynamic" mkFunSize :: FunPtr (IO Int) -> IO Int+foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> IO ()) -> Ptr () -> IO ()+evalCode :: (FunPtr f -> f) -> Code -> IO f+evalCode wrap code = do + binary <- snd $ specialize hostArch getAddressJIT code+ unsafeUseAsCString binary $ return . wrap . castPtrToFunPtr+execCode instrs = do+ id <- languageState $ state createSym + join $ evalCode mkProc (Code [] instrs (symBind id))++getAddress arch lookup register = withRef addressRef getAddr . getAddr+ where + getAddr id = lookup id >>= \val -> case val of+ Just a -> return a+ Nothing -> gets language >>= \lang -> (>> getAddr id) $ case lookupSymVal id lang of+ Verb c -> do+ let (size,codem) = specialize arch getAddr c+ ptr <- mallocForeignPtrBytes size+ register id ptr size + code <- codem+ withForeignPtr ptr $ \p' -> unsafeUseAsCStringLen code $ \(p,n) -> copyBytes p' (castPtr p) n+ Noun size init -> do+ size <- join $ evalCode mkFunSize size+ ptr <- mallocForeignPtrBytes size+ register id ptr size+ withForeignPtr ptr $ \p -> evalCode mkFunInit init >>= ($castPtr p)+ _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show id) (lookupSymName id lang)+ +getAddressJIT = getAddress hostArch lookup register+ where lookup id = do+ val <- M.lookup id $< gets jitAddresses+ return $ (fromIntegral . ptrToIntPtr . unsafeForeignPtrToPtr) $< val+ register id ptr size = modifyF jitAddressesF (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 <- getF compTopF + modifyF compAddressesF (M.insert id (n,ptr))+ modifyF compTopF (+size)++-- 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 DPCodeECT, INDPCodeECT, 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/Context/Language.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}++module Context.Language where++import My.Prelude++import Data.Maybe+import My.Data.List+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Bimap as BM++import My.Control.Monad+import My.Control.Monad.State+import Control.Monad.Trans++import ID+import PCode+import Context.Types as C+import Translate++showTable name showLine contents = (name++":"):map (" "++) (concatMap showLine contents)+instance Show Language where+ show e = intercalate "\n" $ showTable "Context" id [+ ["Max ID: "++show (maxID e)],+ showTable "Symbols" (\(s,i) -> [s++" -> "++show i]) $ BM.toList (symMap e),+ showTable "Aliases" (\(i,i') -> [show i++" -> "++show i']) $ M.toList (aliasMap e),+ showTable "Equivs" (\(i,i') -> [show i++" -> "++show i']) $ M.toList (equivMap e),+ showTable "Modules" (\(s,IDRange r) -> [s++" -> "++show r]) $ BM.toList (modMap e),+ showTable "Values" (\(i,v) -> [show i++" -> "++show v]) $ M.toList (valMap e),+ ["Exports: "++show (exports e)],+ ["Load code: "++show (loadCode e)]]++empty = Language (toEnum 0) BM.empty M.empty M.empty BM.empty M.empty S.empty undefined++createSym e@(Language { maxID = m }) = (m,e { maxID = succ m })+setSymVal id v e = e { valMap = M.insert id v (valMap e) }+lookupSymName id e = BM.lookupR id (symMap e)+lookupSymVal id e = fromMaybe NoValue $ M.lookup id (valMap e) +lookupSymMod id e = BM.lookupR (singleRange id) (modMap e) +addExport id e = e { exports = S.insert id (exports e) }+getImports e = map fst $ BM.toList $ modMap e+isImport im e = BM.member im (modMap e)+exportSymVal id v = setSymVal id v . addExport id++internSym s e = runState (st $ BM.lookup s (symMap e)) e + where st (Just id) = return id+ st _ = do+ i <- state createSym + modifyF symsF (BM.insert s i) + return i++envCast t = traverseM (state . intern) t+ where intern "?" = createSym+ intern str = internSym str+ +importLanguage :: MonadState Context m => (String -> m Language) -> String -> m ()+importLanguage getImport imp = merge imp+ where + getImp imp = do+ l' <- getImport imp+ mapM_ merge [imp | (imp,_) <- BM.toList (modMap l')]+ return l'+ merge imp = gets language >>= \l -> if imp`isImport`l then return () else getImp imp >>= \l' -> doF languageF $ do+ let syms' = symMap l' ; mods' = modMap l' ; mi' = maxID l'+ mapM (state . internSym) (BM.keys syms')+ Language { maxID = mi, symMap = syms } <- get+ let aliases = [(i'+mi,fromJust $ BM.lookup s' syms) + | (s',i') <- BM.toList syms']+ modify $ \l -> l {+ maxID = mi+mi',+ aliasMap = aliasMap l `M.union` M.fromList aliases,+ equivMap = equivMap l `M.union` M.fromList (map swap aliases)+ }+ Language { aliasMap = al , modMap = mods } <- get+ let tr s = fromMaybe (tr' s) $ M.lookup (tr' s) al+ tr' s' = fromMaybe (s' + mi) $ do+ m <- lookupSymMod s' l'+ IDRange (r,_) <- BM.lookup m mods+ IDRange (r',_) <- BM.lookup m mods'+ return $ s'-r'+r+ newVals = M.mapKeys tr $ M.map (translate tr) $ valMap l'+ modify $ \l -> l {+ modMap = BM.insert imp (IDRange (mi,mi+mi')) (modMap l),+ valMap = M.unionWith (\_ a -> a) (valMap l) newVals,+ exports = S.difference (exports l) (M.keysSet newVals) + }+ +exportLanguage e = e {+ symMap = BM.filter exportNameP (symMap e),+ valMap = vals',+ aliasMap = M.empty,+ equivMap = M.empty,+ exports = S.empty,+ loadCode = translate trans (loadCode e)+ }+ where set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined))+ ex = exports e ; eqs = equivMap e+ vals' = M.map (translate trans) $ M.intersection (valMap e) (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)+ && not (M.member s eqs)+ references val = case val of+ Verb code -> codeRefs code + Noun size init -> codeRefs size ++ codeRefs init+ _ -> []++-- 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 DPCodeECT, INDPCodeECT, 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/Context/Types.hs view
@@ -0,0 +1,51 @@+module Context.Types where++import Foreign.ForeignPtr+import Data.Word+import Data.Bimap+import Data.Map+import Data.Set+import My.Control.Monad.State+import ID+import PCode+import Syntax++data Axiom = XAlter | XBind + | XReturn | XRestart | XChoose | XDo+ | XLang | XVerb | XNoun+ | XID | XAddr | XSize + deriving Show++data Value = Axiom Axiom+ | Builtin Builtin+ | Verb Code+ | Noun Code Code+ | NoValue+ deriving Show++data Language = Language {+ maxID :: ID,+ symMap :: Bimap String ID,+ aliasMap :: Map ID ID,+ equivMap :: Map ID ID,+ modMap :: Bimap String IDRange,+ valMap :: Map ID Context.Types.Value,+ exports :: Set ID,+ loadCode :: [Instruction]+ }+symsF = Field (symMap,\s ce -> ce { symMap = s })+valsF = Field (valMap,\v ce -> ce { valMap = v })++data Context = C {+ language :: Language,+ jitAddresses :: Map ID (ForeignPtr Word8),+ compAddresses :: Map ID (Int,ForeignPtr Word8),+ compTop :: Int,+ transform :: Syntax ID -> IO (Syntax ID)+ }+jitAddressesF = Field (jitAddresses,\a c -> c { jitAddresses = a })+compAddressesF = Field (compAddresses,\a c -> c { compAddresses = a })+languageF = Field (language,\a c -> c { language = a })+compTopF = Field (compTop,\a c -> c { compTop = a })++
+ src/Elf.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Elf (writeElf) 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 ()+ +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))+ ++-- 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 DPCodeECT, INDPCodeECT, 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/Environment.hs
@@ -1,22 +0,0 @@-module Environment(- module Environment.Axiom,- module Environment.Context,- module Environment.Foreign,- module Environment.Value) where--import Environment.Axiom-import Environment.Context-import Environment.Foreign-import Environment.Value----- 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/Environment/Axiom.hs
@@ -1,19 +0,0 @@-module Environment.Axiom where--data Axiom = XAlter | XBind - | XReturn | XRestart | XChoose | XDo- | XRune | XVerb | XNoun- | XID | XAddr | XSize - deriving Show----- 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/Environment/Context.hs
@@ -1,126 +0,0 @@-module Environment.Context where--import IR-import Data.Maybe-import Environment.Value as E-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Bimap as BM-import Control.Monad.State-import Util.State-import Util.ID-import Util.List-import Util.Monad-import Util.Prelude-import Translate--data Context = CE {- maxID :: ID,- symMap :: BM.Bimap String ID,- aliasMap :: M.Map ID ID,- equivMap :: M.Map ID ID,- modMap :: BM.Bimap String IDRange,- valMap :: M.Map ID E.Value,- exports :: S.Set ID,- load :: [Instruction]- }--showTable name showLine contents = (name++":"):map (" "++) (concatMap showLine contents)-instance Show Context where- show e = intercalate "\n" $ showTable "Environment" id [- ["Max ID: "++show (maxID e)],- showTable "Symbols" (\(s,i) -> [s++" -> "++show i]) $ BM.toList (symMap e),- showTable "Aliases" (\(i,i') -> [show i++" -> "++show i']) $ M.toList (aliasMap e),- showTable "Equivs" (\(i,i') -> [show i++" -> "++show i']) $ M.toList (equivMap e),- showTable "Modules" (\(s,IDRange r) -> [s++" -> "++show r]) $ BM.toList (modMap e),- showTable "Values" (\(i,v) -> [show i++" -> "++show v]) $ M.toList (valMap e),- ["Exports: "++show (exports e)],- ["Load code: "++show (load e)]]--empty = CE (toEnum 0) BM.empty M.empty M.empty BM.empty M.empty S.empty []--symsF = (symMap,\s ce -> ce { symMap = s })-valsF = (valMap,\v ce -> ce { valMap = v })--createSym e@(CE { maxID = m }) = (m,e { maxID = succ m })-setSymVal id v e = e { valMap = M.insert id v (valMap e) }-lookupSymName id e = BM.lookupR id (symMap e)-lookupSymVal id e = fromMaybe NoValue $ M.lookup id (valMap e) -lookupSymMod id e = BM.lookupR (singleRange id) (modMap e) -addExport id e = e { exports = S.insert id (exports e) }-getImports e = map fst $ BM.toList $ modMap e-isImport im e = BM.member im (modMap e)-exportSymVal id v = setSymVal id v . addExport id--internSym s e = runState (st $ BM.lookup s (symMap e)) e - where st (Just id) = return id- st _ = do- i <- state createSym - modifyF symsF (BM.insert s i) - return i--envCast t e = runState (traverseM (state . intern) t) e- where intern "?" = createSym- intern str = internSym str- -instance Num ID where- ID a + ID b = ID (a+b)- ID a - ID b = ID (a-b)- (*) = undefined- negate = undefined- abs = undefined- signum = undefined- fromInteger = undefined- -merge e (mod,e') = if isImport mod e then e else ret- where ret = execState st e - syms' = symMap e' ; mods' = modMap e' ; mi' = maxID e'- st = do - mapM (state . internSym) (BM.keys syms')- mi <- gets maxID ; syms <- gets symMap- let aliases = [(i'+mi,fromJust $ BM.lookup s' syms) - | (s',i') <- BM.toList syms']- modify $ \e -> e {- maxID = mi+mi',- aliasMap = aliasMap e `M.union` M.fromList aliases,- equivMap = equivMap e `M.union` M.fromList (map swap aliases)- }- CE { aliasMap = al , modMap = mods } <- get- let tr s = fromMaybe (tr' s) $ M.lookup (tr' s) al- tr' s' = fromMaybe (s' + mi) $ do- m <- lookupSymMod s' e'- IDRange (r,_) <- BM.lookup m mods- IDRange (r',_) <- BM.lookup m mods'- return $ s'-r'+r- newVals = M.mapKeys tr $ M.map (translate tr) $ valMap e'- modify $ \e -> e {- modMap = BM.insert mod (IDRange (mi,mi+mi')) (modMap e),- valMap = M.unionWith (\_ a -> a) (valMap e) newVals,- exports = S.difference (exports e) (M.keysSet newVals) - }- -exportContext e = e {- symMap = BM.filter exportNameP (symMap e),- valMap = vals',- aliasMap = M.empty,- equivMap = M.empty,- exports = S.empty- }- where set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined))- ex = exports e ; eqs = equivMap e- vals' = M.map (translate tr) $ M.intersection (valMap e) (set2Map ex)- where tr 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)- && not (M.member s eqs)---- 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/Environment/Foreign.hs
@@ -1,62 +0,0 @@-module Environment.Foreign( - getEnv,setEnv,withEnv,stateEnv,- defaultEnv,- doTransform- )where--import System.IO.Unsafe (unsafePerformIO)-import Data.IORef-import Environment.Axiom-import Environment.Value-import Environment.Context-import IR-import Util.ID-import Syntax-import Control.Monad.State--defaultEnv = fromList $ [- ("alter" ,Axiom XAlter),- ("bind" ,Axiom XBind),- - ("choose" ,Axiom XChoose),- ("<-" ,Axiom XRestart),- ("->" ,Axiom XReturn),- ("do" ,Axiom XDo),- - ("rune" ,Axiom XRune),- ("verb" ,Axiom XVerb),- ("noun" ,Axiom XNoun), - - ("id" ,Axiom XID),- ("@" ,Axiom XAddr),- ("#" ,Axiom XSize)]- ++ [(n,Builtin b) | (b,n) <- bNames]- where fromList l = execState (mapM_ st l) empty- st (s,v) = state (internSym s) >>= \i -> modify (setSymVal i v)--context :: IORef Context-context = unsafePerformIO $ newIORef defaultEnv--getEnv = readIORef context-setEnv = writeIORef context-withEnv e a = do- e' <- getEnv- setEnv e- ret <- a- setEnv e'- return ret-stateEnv st = getEnv >>= \e -> let (e',s') = runState st e in setEnv s' >> return e'-doTransform syn = return syn------ 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/Environment/Value.hs
@@ -1,39 +0,0 @@-module Environment.Value where--import IR.Instruction-import IR.Builtin-import IR.Value-import Environment.Axiom-import Util.ID-import qualified Data.Set as S-import Data.Tree--data Value = Axiom Axiom- | Builtin Builtin- | Verb [BindVar] BindVar [Instruction] - | Noun BindVar [Instruction]- | NoValue- deriving Show--references val = case val of- Verb args ret code -> refs code (bindSyms ret++concatMap bindSyms args)- Noun ret code -> refs code (bindSyms ret)- _ -> []- where refs code local = traverse (S.fromList local) (instrTree 0 nexts)- where (_,instr,nexts,_) = navigate code- traverse local (Node i subs) = valRefs (instrVals (instr i)) ++ concatMap (traverse newLocal) subs- where valRefs vals = [v | SymVal t v <- vals, t==SymID || not (S.member v local)]- newLocal = S.union local (S.fromList (instrVars (instr i)))- ----- 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/ID.hs view
@@ -0,0 +1,42 @@+module ID where++newtype ID = ID Int+ deriving (Ord,Eq)+newtype IDRange = IDRange (ID,ID)+ deriving Show+ +singleRange i = IDRange (i,i)++instance Eq IDRange where+ a == b = compare a b == EQ+instance Ord IDRange where+ compare (IDRange (a,b)) (IDRange (a',b')) = + if b<=a' then LT+ else if b'<=a then GT+ else EQ++instance Enum ID where+ toEnum = ID+ fromEnum (ID i) = i+instance Show ID where+ show (ID i) = "x"++show i+instance Num ID where+ ID a + ID b = ID (a+b)+ ID a - ID b = ID (a-b)+ ID a * ID b = ID (a*b)+ negate = undefined+ abs = undefined+ signum = undefined+ fromInteger n = ID $ fromInteger n+++-- 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 DPCodeECT, INDPCodeECT, 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/IR.hs
@@ -1,24 +0,0 @@-module IR(- module IR.Builtin,- module IR.Instruction,- module IR.Value) where--import IR.Builtin-import IR.Instruction-import IR.Value--------- 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/IR/Builtin.hs
@@ -1,25 +0,0 @@-module IR.Builtin where--data Builtin = BAdd | BMul | BSub | BDiv | BMod - | BAnd | BOr | BXor | BNot- | BLowerEq | BLowerThan | BGreaterEq | BGreaterThan - | BEqual | BNotEqual- | BCall- | BSet- deriving (Show,Eq)--bNames = [(BAdd,"+"),(BMul,"*"),(BSub,"-"),(BDiv,"/"),(BMod,"%"),- (BLowerThan,"<"),(BGreaterThan,">"),(BLowerEq,"<="),(BGreaterEq,">="),- (BEqual,"="),(BNotEqual,"<>"),- (BAnd,"&"),(BOr,"|"),(BXor,"x|"),(BNot,"not")]---- 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/IR/Instruction.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-module IR.Instruction where--import Control.Monad.State-import Data.List-import Data.Maybe-import Data.Array-import Data.Tree-import qualified Data.Set as S-import IR.Builtin-import IR.Value-import Util.ID--type Addr = Int-data BindVar = BindVar { - bindSym :: ID, - bindSize :: (Int,Int), - bindPad :: Int, - bindSubs :: [(BindVar,Int)]- }-data Instruction = Op Builtin ID [Value]- | Branch Value [Addr]- | Bind BindVar Value- | Noop- -isNoop Noop = True-isNoop _ = False-isBranch (Branch _ _) = True-isBranch _ = False--bindSyms bv = bindSym bv : concatMap bindSyms (map fst $ bindSubs bv)-instrVals (Op _ _ vs) = vs-instrVals (Bind _ v) = [v]-instrVals (Branch v _) = [v]-instrVals _ = []-instrVars (Op _ v _) = [v]-instrVars (Bind v _) = bindSyms v-instrVars _ = []--set v val = Op BSet v [val]-call v f args = Op BCall v (f:args)-ret = Branch NullVal []--concatCode c1 [] = c1-concatCode c1 c2 = map (f g1) c1 ++ map (f g2) c2- where f g (Branch v as) = Branch v (g as)- f _ i = i- g1 as = if null as then [l] else as- g2 as = map (l+) as- l = length c1--navigate code = (bs,instr,nexts,prevs)- where bs@(bMin,bMax) = (0,length code-1)- instr n = listArray bs code!n- nexts (instr -> Branch _ l) = l- nexts n = [n+1]- prevs n = accumArray (flip (:)) [] bs [(n,i) | i <- [bMin..bMax], n <- nexts i] ! n--instrTree seed nexts = evalState (unfoldTreeM unfold seed) S.empty- where unfold seed = do modify (S.insert seed) ; s <- get - return (seed,[n | n <- nexts seed, not $ S.member n s])- -instance Show Instruction where - show (Op BCall d (f:args)) = show d ++ " = " ++ show f ++ "(" ++ intercalate "," (map show args) ++ ")"- show (Op BSet v [val]) = show v ++ " = " ++ show val- show (Op o d vs) = show d ++ " = " ++ intercalate (" "++opStr++" ") (map show vs)- where opStr = fromMaybe (error $ "unknown pervasive "++show o) $ lookup o bNames- show (Branch _ []) = "return"- show (Branch _ [off]) = "goto " ++ show off- show (Branch v off) = "case " ++ show v ++ " " ++ show off - show (Bind vars x) = "bind "++show vars++" "++show x- show Noop = "noop"-instance Show BindVar where- show (BindVar v (n,nr) pad subs) = case (pad,subs) of- (0,[]) -> head varStr- _ -> "["++intercalate " " (varStr++padStr++subsStr)++"]"- where varStr = [show v++":"++if sizeStr=="" then "0" else sizeStr]- sizeStr = intercalate "+" (size++regSize)- size = if n==0 then [] else [show n]- regSize = if nr==0 then [] else [show nr++"r"]- padStr = if pad==0 then [] else [show pad]- subsStr = map show subs---- 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/IR/Value.hs
@@ -1,47 +0,0 @@-module IR.Value where--import Control.Monad-import Control.Monad.Instances-import Data.Char-import Data.List-import Data.Maybe-import Util.Prelude-import Util.ID--data ValType = Value | Address | Size | SymID- deriving Eq-data Value = SymVal ValType ID- | IntVal Int- | NullVal--varEqVal n (SymVal Value n') = n==n'-varEqVal _ _ = False--readConstant s = let (a,b) = break (=='#') (filter (/='-') s) in eitherToMaybe $- parseInt 10 a >>= \r -> if null b then return r else parseInt r (tail b)--parseInt r s - | all isHexDigit s =- case find (>=r) digs of - Just d -> Left $ "digit '"++[intToDigit d]++"' too great for base "++show r++" (in numeral constant '"++s++"')" - Nothing -> Right $ sum $ zipWith (*) (reverse digs) $ iterate (*r) 1- | otherwise = Left $ "all digits must be alphanumeric characters (in constant '"++s++"')"- where digs = map digitToInt s- -instance Show Value where- show (SymVal t v) = prefix++show v- where prefix = fromJust $ lookup t [(Value,""),(Address,"@"),(Size,"#"),(SymID,"$")]- show (IntVal n) = show n- show NullVal = "(null)"----- 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/My/Control/Monad.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module My.Control.Monad (module Control.Monad,($<),(>$),(>$<),(§),(§<),(>§),(>§<),(<&&>),(<||>),ifM,findM,traverseM) where++import Control.Monad+import Data.Traversable+import Control.Applicative++($<) :: Monad m => (a -> b) -> m a -> m b+(>$) :: Monad m => m (a -> b) -> a -> m b+(>$<) :: Monad m => m (a -> b) -> m a -> m b+($<) = liftM+mf >$ x = mf >>= \f -> return (f x)+(>$<) = ap+ +(§) = flip ($)+(§<) = flip (>$)+(>§) = flip ($<)+(>§<) = flip (>$<) ++ifM b th el = b >>= \b -> if b then th else el+a <&&> b = ifM a b (return False)+a <||> b = ifM a (return True) b++findM p l = foldr fun (return Nothing) l+ where fun x ret = ifM (p x) (return $ Just x) ret++traverseM f = unwrapMonad . traverse (WrapMonad . f)++-- 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 DPCodeECT, INDPCodeECT, 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/My/Control/Monad/State.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TupleSections, NoMonomorphismRestriction #-}+module My.Control.Monad.State(+ module Control.Monad.State, + Field(..),(<.>),+ stateF,doF,modifyF,getF,getsF,putF,swapF,+ fstF,sndF,+ withState+ ) where++import Control.Monad.State hiding (withState)++newtype Field f s = Field (s -> f,f -> s -> s)++fstF = Field (fst,(\x (a,b) -> (x,b))) :: Field a (a,b)+sndF = Field (snd,(\y (a,b) -> (a,y))) :: Field b (a,b)++stateF (Field (m,m')) st = get >>= \s -> let (v,st') = st (m s) in put (m' st' s) >> return v+doF f st = stateF f (runState st)+modifyF fld f = stateF fld (\s -> ((),f s))+getF (Field (f,_)) = gets f +getsF (Field (f,_)) g = gets (g . f)+putF f v = modifyF f (const v)+swapF f v = stateF f (,v) ++Field (f,f') <.> Field (g,g') = Field (g . f, (\g s -> f' (g' g (f s)) s)) ++withState s mx = get >>= \v -> put s >> mx >>= \x -> put v >> return x++-- 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 DPCodeECT, INDPCodeECT, 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/My/Control/Monad/TimeLine.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-}+module My.Control.Monad.TimeLine where++import Data.Functor.Identity+import Control.Monad.Fix+import Control.Monad.Trans+import My.Control.Monad+import My.Control.Monad.State++fst3 (a,_,_) = a+snd3 (_,a,_) = a++newtype TimeLineT p f m a = TimeLineT { runTimeLineT :: (p,f) -> m (p,f,a) }+type TimeLine p f = TimeLineT p f Identity++instance MonadFix m => Monad (TimeLineT p f m) where+ tl >>= cc = TimeLineT tl'+ where tl' (p,f) = do rec { (p',f'',a) <- runTimeLineT tl (p,f') ;+ (p'',f',b) <- runTimeLineT (cc a) (p',f) }+ return (p'',f'',b)+ return a = TimeLineT (\(p,f) -> return (p,f,a))+instance MonadTrans (TimeLineT p f) where+ lift ma = TimeLineT (\(p,f) -> ma >§ \a -> (p,f,a))+instance (MonadPlus m,MonadFix m) => MonadPlus (TimeLineT p f m) where+ mzero = lift $ mzero+ mplus a b = TimeLineT (\t -> runTimeLineT a t `mplus` runTimeLineT b t)+++timeLine tl = TimeLineT (Identity . tl)+runTimeLine tl x = runIdentity $ runTimeLineT tl x++statetl = TimeLineT . \k st -> k st >§ \(a,(p,f)) -> (p,f,a)+runtl = statetl . runStateT++-- 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 DPCodeECT, INDPCodeECT, 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/My/Data/Graph.hs view
@@ -0,0 +1,85 @@+module My.Data.Graph( + Language,Graph,Node(..),+ + empty,+ lookupLanguage,getLanguage,+ insertNode,deleteNode,modifyNode,+ insertEdge,deleteEdge,+ + modifyInEdges,modifyOutEdges,+ tag,inEdges,outEdges,edges,+ nextNodes,prevNodes,+ + nodeList,nodeListFull,+ + mapNodes+ )+ where++import qualified Data.Map as M+import Data.List+import Data.Maybe++type Node = Int+data Language e n = Language { + nodeTag :: n, + nodeInEdges :: M.Map Node e, + nodeOutEdges :: M.Map Node e+ } deriving Show+data Graph e n = Graph {+ nbNodes :: Int,+ graphNodes :: M.Map Node (Language e n)+ }+ +empty = Graph 0 M.empty++lookupLanguage n (Graph _ nds) = M.lookup n nds+getLanguage n g = fromMaybe (error $ "No node "++show n++" in graph "++show g) $ lookupLanguage n g++insertNode x (Graph n nds) = (n,Graph (n+1) (M.insert n (Language x M.empty M.empty) nds))+deleteNode nd (Graph n nds) = Graph n (M.delete nd nds)+modifyNode nd f (Graph n nds) = Graph n (M.adjust (\(Language t i o) -> Language (f t) i o) nd nds)++insertEdge x n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.insert n1 x)) n2 $+ M.adjust (modifyOutEdges (M.insert n2 x)) n1 nds) +deleteEdge n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.delete n1)) n2 $+ M.adjust (modifyOutEdges (M.delete n2)) n1 nds)++modifyInEdges f c = c { nodeInEdges = f $ nodeInEdges c }+modifyOutEdges f c = c { nodeOutEdges = f $ nodeOutEdges c }++tag = nodeTag+inEdges = M.toList . nodeInEdges+outEdges = M.toList . nodeOutEdges+edges c = (inEdges c,outEdges c)++nextNodes = map fst . outEdges+prevNodes = map fst . inEdges++nodeList = map fst . nodeListFull+nodeListFull = M.toList . graphNodes++mapNodes f (Graph n nds) = Graph n (M.mapWithKey (\n (Language t ie oe) -> Language (f n t) ie oe) nds)++instance Functor (Graph e) where+ fmap f = mapNodes (const f)+instance (Show n,Show e) => Show (Graph e n) where+ show (Graph _ nds) = intercalate "\n" showNodes+ where showNodes = map showNode $ M.toList nds+ showNode (n,Language nd ie oe) = + show n++": "++show nd++"\n "+++ intercalate "\n " (map showNEdge (M.toList oe)+ ++ map showREdge (M.toList ie))+ where showNEdge (n',e) = "--"++show e++"--> "++show n'+ showREdge (n',e) = "<--"++show e++"-- "++show n'++-- 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 DPCodeECT, INDPCodeECT, 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/My/Data/List.hs view
@@ -0,0 +1,21 @@+module My.Data.List(module Data.List,classesBy,nubOrd) where++import Data.List++nubOrd :: Ord a => [a] -> [a]+nubOrd = map head . group . sort++classesBy :: (a -> a -> Bool) -> [a] -> [[a]]+classesBy (==) [] = []+classesBy (==) (e:l) = let (x,t) = partition (e==) l in (e:x):classesBy (==) t++-- 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 DPCodeECT, INDPCodeECT, 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/My/Prelude.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module My.Prelude where++import System.Posix.Files+import Data.Maybe+import Debug.Trace+import My.Control.Monad++debug x = traceShow x x++maybeToEither = maybe (Left undefined) Right+eitherToMaybe = either (const Nothing) Just++ifThenElse b th el = if b then th else el++swap (a,b) = (b,a)++newerThan f1 f2 = liftM2 (>) (modTime f1) (modTime f2)+ where modTime f = modificationTime $< getFileStatus f+++-- 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 DPCodeECT, INDPCodeECT, 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/Options.hs view
@@ -0,0 +1,68 @@+module Options (Architecture(..),Action(..),Settings(..),helpMsg,getSettings) where++import Specialize.Architecture+import System.Console.GetOpt+import Data.Maybe+import My.Data.List++data Flag = Help | Version+ | SourceDir FilePath + | Program FilePath + | LanguageDir FilePath + | Architecture Architecture + deriving Show+data Action = PrintHelp | PrintVersion | Compile+ deriving Show++data Settings = Settings {+ action :: Action,+ sourceDirs :: [FilePath],+ languageDir :: FilePath,+ programs :: [FilePath],+ outputArch :: Architecture+ }+ deriving Show++options = + [Option ['h'] ["help"] (NoArg Help) + "prints usage information"+ ,Option ['v'] ["version"] (NoArg Version) + "prints Alpha's version information"+ ,sep+ ,Option ['S'] ["source-dir"] (ReqArg SourceDir "DPCode") + "adds DPCode to the list of directories searched for sources"+ ,Option ['L'] ["language-dir"] (ReqArg LanguageDir "DPCode") + "casts all languages in DPCode (default '.')"+ ,sep+ ,Option ['a'] ["architecture"] (ReqArg (Architecture . str2arch) "ARCH") + $ "specializes for ARCH instead of the local architecture (ARCH is one of "++foldr glue "" (tails archNames)++")"+ ]+ where str2arch s = fromMaybe (error $ "Invalid architecture name "++s) $ lookup s $ zip archNames architectures+ archNames = map archName architectures+ glue [a] _ = a+ glue [a,_] t = a++" or "++t+ glue (a:_) t = a++", "++t+ sep = Option [] [] undefined "-----------------"+helpMsg = usageInfo "Usage: Alpha <options> <files>" options++defaultSettings progs = Settings Compile ["."] "." progs hostArch+getSettings [] = Right $ defaultSettings []+getSettings args = case getOpt Permute options args of+ (opts,mods,[]) -> Right $ foldl handleOpt (defaultSettings mods) opts+ (_,_,err) -> Left $ helpMsg ++ concatMap ("\n"++) err+ where handleOpt s Help = s { action = PrintHelp }+ handleOpt s Version = s { action = PrintVersion }+ handleOpt s (SourceDir d) = s { sourceDirs = d : sourceDirs s }+ handleOpt s (LanguageDir d) = s { languageDir = d }+ handleOpt s (Architecture a) = s { outputArch = a }++-- 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 DPCodeECT, INDPCodeECT, 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/PCode.hs view
@@ -0,0 +1,19 @@+module PCode(+ module PCode.Builtin,+ module PCode.Instruction,+ module PCode.Value) where++import PCode.Builtin+import PCode.Instruction+import PCode.Value++-- 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 DPCodeECT, INDPCodeECT, 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/PCode/Builtin.hs view
@@ -0,0 +1,25 @@+module PCode.Builtin where++data Builtin = BAdd | BMul | BSub | BDiv | BMod + | BAnd | BOr | BXor | BNot+ | BLowerEq | BLowerThan | BGreaterEq | BGreaterThan + | BEqual | BNotEqual+ | BCall+ | BSet+ deriving (Show,Eq)++bNames = [(BAdd,"+"),(BMul,"*"),(BSub,"-"),(BDiv,"/"),(BMod,"%"),+ (BLowerThan,"<"),(BGreaterThan,">"),(BLowerEq,"<="),(BGreaterEq,">="),+ (BEqual,"=="),(BNotEqual,"<>"),+ (BAnd,"&"),(BOr,"|"),(BXor,"x|"),(BNot,"not")]++-- 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 DPCodeECT, INDPCodeECT, 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/PCode/Instruction.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE ViewPatterns #-}+module PCode.Instruction where++import Control.Monad.State+import Data.List+import Data.Maybe+import Data.Array+import Data.Tree+import qualified Data.Set as S+import PCode.Builtin+import PCode.Value+import ID++type Addr = Int+data BindVar = BindVar { + bindSym :: ID, + bindSize :: (Int,Int), + bindPad :: Int, + bindSubs :: [(BindVar,Int)]+ }+data Instruction = Op Builtin ID [Value]+ | Branch Value [Addr]+ | Bind BindVar Value+ | Noop+data Code = Code [BindVar] [Instruction] BindVar+ deriving Show++isNoop Noop = True+isNoop _ = False+isBranch (Branch _ _) = True+isBranch _ = False++bindSyms bv = bindSym bv : concatMap bindSyms (map fst $ bindSubs bv)+symBind s = BindVar s (0,1) 0 []+instrVals (Op _ _ vs) = vs+instrVals (Bind _ v) = [v]+instrVals (Branch v _) = [v]+instrVals _ = []+instrVars (Op _ v _) = [v]+instrVars (Bind v _) = bindSyms v+instrVars _ = []++set v val = Op BSet v [val]+call v f args = Op BCall v (f:args)+ret = Branch NullVal []++concatCode c1 [] = c1+concatCode c1 c2 = map (f g1) c1 ++ map (f g2) c2+ where f g (Branch v as) = Branch v (g as)+ f _ i = i+ g1 as = if null as then [l] else as+ g2 as = map (l+) as+ l = length c1++navigate code = (bs,instr,nexts,prevs)+ where bs@(bMin,bMax) = (0,length code-1)+ instr n = listArray bs code!n+ nexts (instr -> Branch _ l) = l+ nexts n = [n+1]+ prevs n = accumArray (flip (:)) [] bs [(n,i) | i <- [bMin..bMax], n <- nexts i] ! n++spanningTree seed nexts = evalState (unfoldTreeM unfold seed) S.empty+ where unfold seed = do modify (S.insert seed) ; s <- get + return (seed,[n | n <- nexts seed, not $ S.member n s])+ +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) = refs code (bindSyms ret++concatMap bindSyms args)+ where refs code local = traverse (S.fromList local) (spanningTree 0 nexts)+ where (_,instr,nexts,_) = navigate code+ traverse local (Node i subs) = valRefs (instrVals (instr i)) ++ concatMap (traverse newLocal) subs+ where valRefs vals = [v | SymVal t v <- vals, t==SymID || not (S.member v local)]+ newLocal = S.union local (S.fromList (instrVars (instr i)))+ +instance Show Instruction where + show (Op BCall d (f:args)) = show d ++ " = " ++ show f ++ "(" ++ intercalate "," (map show args) ++ ")"+ show (Op BSet v [val]) = show v ++ " = " ++ show val+ show (Op o d vs) = show d ++ " = " ++ intercalate (" "++opStr++" ") (map show vs)+ where opStr = fromMaybe (error $ "unknown builtin "++show o) $ lookup o bNames+ show (Branch _ []) = "return"+ show (Branch _ [off]) = "goto " ++ show off+ show (Branch v off) = "case " ++ show v ++ " " ++ show off + show (Bind vars x) = "bind "++show vars++" "++show x+ show Noop = "noop"+instance Show BindVar where+ show (BindVar v (n,nr) pad subs) = case (pad,subs) of+ (0,[]) -> head varStr+ _ -> "["++intercalate " " (varStr++padStr++subsStr)++"]"+ where varStr = [show v++":"++if sizeStr=="" then "0" else sizeStr]+ sizeStr = intercalate "+" (size++regSize)+ size = if n==0 then [] else [show n]+ regSize = if nr==0 then [] else [show nr++"r"]+ padStr = if pad==0 then [] else [show pad]+ subsStr = map show subs++-- 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 DPCodeECT, INDPCodeECT, 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/PCode/Value.hs view
@@ -0,0 +1,47 @@+module PCode.Value where++import Control.Monad+import Control.Monad.Instances+import Data.Char+import Data.List+import Data.Maybe+import My.Prelude+import ID++data ValType = Value | Address | Size | SymID+ deriving Eq+data Value = SymVal ValType ID+ | IntVal Int+ | NullVal++varEqVal n (SymVal Value n') = n==n'+varEqVal _ _ = False++readConstant s = let (a,b) = break (=='#') (filter (/='-') s) in eitherToMaybe $+ parseInt 10 a >>= \r -> if null b then return r else parseInt r (tail b)++parseInt r s + | all isHexDigit s =+ case find (>=r) digs of + Just d -> Left $ "digit '"++[intToDigit d]++"' too great for base "++show r++" (in numeral constant '"++s++"')" + Nothing -> Right $ sum $ zipWith (*) (reverse digs) $ iterate (*r) 1+ | otherwise = Left $ "all digits must be alphanumeric characters (in constant '"++s++"')"+ where digs = map digitToInt s+ +instance Show Value where+ show (SymVal t v) = prefix++show v+ where prefix = fromJust $ lookup t [(Value,""),(Address,"@"),(Size,"#"),(SymID,"$")]+ show (IntVal n) = show n+ show NullVal = "(null)"+++-- 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 DPCodeECT, INDPCodeECT, 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/Serialize.hs view
@@ -5,29 +5,31 @@ import GHC.Generics import Data.Serialize -import Util.Monad+import My.Control.Monad import Data.Bimap as BM-import Util.ID-import IR-import Environment as E+import ID+import PCode+import Context as C deriving instance Generic ValType-deriving instance Generic IR.Value+deriving instance Generic PCode.Value+deriving instance Generic Code deriving instance Generic Instruction deriving instance Generic BindVar deriving instance Generic Builtin-deriving instance Generic E.Value+deriving instance Generic C.Value deriving instance Generic Axiom deriving instance Generic ID deriving instance Generic IDRange-deriving instance Generic Context+deriving instance Generic Language instance Serialize ValType-instance Serialize IR.Value+instance Serialize PCode.Value+instance Serialize Code instance Serialize Instruction instance Serialize BindVar instance Serialize Builtin-instance Serialize E.Value+instance Serialize C.Value instance Serialize Axiom instance Serialize ID instance Serialize IDRange@@ -35,7 +37,7 @@ get = BM.fromList $< get put = put . BM.toList -instance Serialize Context+instance Serialize Language -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com> -- All rights reserved.@@ -45,5 +47,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Specialize.hs view
@@ -1,77 +1,11 @@-{-# LANGUAGE TupleSections, ViewPatterns #-}-module Specialize where+module Specialize(specialize) where -import Specialize.Types+import PCode+import Context.Types+import Data.Word import Specialize.Architecture-import Util.Monad-import Util.State-import Util.List-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Either-import Data.Array-import Data.Maybe-import Data.Tree--import Environment.Value--import IR--addrF = (addresses,\s p -> p { addresses = s })-bindF = (bindings,\s p -> p { bindings = s })-regsF = (registers,\r p -> p { registers = r })-stackF = (stack,\s p -> p { stack = s })--getAddress id = do- p <- getp- case M.lookup id (addresses p) of- Nothing -> runp $ do- a <- stateF stackF (stackAlloc (regSize $ architecture $ p))- modifyF addrF (M.insert id (Nothing,a))- return a- Just (_,a) -> return a--shrinkStack s = concatMap f $ tails $ groupBy (\(f1,_) (f2,_) -> not (f1 || f2)) s- where f [((True,_):_)] = []- f (l@((True,_):_):_) = if total == 0 then [] else [(True,total)]- where total = sum [s | (_,s) <- l]- f ([l]:_) = [l]-stackAlloc n s = (a,shrinkStack s')- where (h,l) = break (\(free,size) -> free && size>=n) s - a = sum $ map snd h- (size,t) = case l of- [] -> (n,[])- ((_,s):t) -> (s,t)- s' = h++[(False,n),(True,size-n)]++t-stackFree n s = shrinkStack [(i==n || fr,sz) | (i,(fr,sz)) <- zip (scanl (+) 0 (map snd s)) s]--code = [- Op BSet r [val b],- Op BSet b [val a],- Op BNotEqual c [val r,IntVal 0],- Branch (val c) [6,4],- Op BSet x [val b],- Branch NullVal [],- Op BSet a [val b],- Op BSet b [val r],- Op BMod r [val a,val b],- Branch NullVal [2] - ]- where [a,b,r,c,x] = map var [0..4]- var = ID- val v = SymVal Value v--specialize arch code = fmap (\n -> (n,instr n)) (instrTree 0 nexts)- where (_,instr,nexts,_) = navigate code - ---- 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.+import ID+import Data.ByteString +specialize :: Monad m => Architecture -> (ID -> m Int) -> Code -> (Int,m ByteString)+specialize arch assoc (Code args code ret) = (1,return $ pack [0x83])
src/Specialize/Architecture.hs view
@@ -1,8 +1,8 @@ module Specialize.Architecture(Architecture(..),arch_x86,arch_x86_64,arch_arm,hostArch,architectures) where import Specialize.Types-import IR.Instruction-import Util.TimeLine+import PCode.Instruction+import My.Control.Monad.TimeLine import Data.Ord import Data.Word import Data.Set as S@@ -13,24 +13,11 @@ show a = "#<Arch:"++archName a++">" architectures = [hostArch,arch_x86,arch_x86_64,arch_arm]-arch_x86 = Arch {- archName = "x86",- registers = S.fromList [0..7],- regSize = 4,- compileInstr = undefined- }-arch_x86_64 = Arch { - archName = "x86_64",- registers = S.fromList [0..15],- regSize = 8,- compileInstr = undefined- }-arch_arm = Arch {- archName = "arm",- registers = S.fromList [0..15],- regSize = 4,- compileInstr = undefined- }+nullArch = Arch undefined undefined undefined undefined+arch_x86 = nullArch { archName = "x86" }+arch_x86_64 = nullArch { archName = "x86_64" }+arch_arm = nullArch { archName = "arm" }+ hostArch = arch_x86_64 { archName = "host" } -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com>@@ -41,5 +28,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Specialize/Types.hs view
@@ -1,34 +1,31 @@ module Specialize.Types(- module Data.Word, module Util.TimeLine,- module IR.Instruction, module Util.ID,+ module Data.Word, module My.Control.Monad.TimeLine,+ module PCode.Instruction, module ID, Register(..),Address(..), Architecture(..), Past(..),Future(..), Allocate(..)) where import Data.Word-import Util.TimeLine-import IR.Instruction-import Util.ID+import My.Control.Monad.TimeLine+import PCode.Instruction+import ID import Data.Map import Data.Set type Register = Int type Address = (Maybe ID,Int) data Architecture = Arch {- archName :: String,- registers :: Set Register,- regSize :: Int,- compileInstr :: Instruction -> Allocate [Word8]+ archName :: String,+ archInitialPast :: [BindVar] -> Past,+ archFinalFuture :: Future,+ archCompileInstr :: Instruction -> (Int -> ((Int,Int),Past)) -> Allocate (Int,[Word8]) } data Past = Past { - architecture :: Architecture,- isActive :: Bool,- addresses :: Map ID Address,- bindings :: Map ID Register,- clobber :: Map ID [ID],- stack :: [(Bool,Int)]+ bindings :: Maybe (Map ID Register),+ clobber :: Map ID [ID],+ stack :: [(Bool,Int)] } data Future = Future { fregs :: Map ID Register
+ src/Specialize/X86.hs view
@@ -0,0 +1,4 @@+module Specialize.X86 where++specializeInstr (Op b vs v) info = do+
src/Syntax.hs view
@@ -24,8 +24,6 @@ show (Symbol s) = show s show (Group l) = "[" ++ intercalate " " (map show l) ++ "]" -- -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com> -- All rights reserved. @@ -34,5 +32,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Syntax/Parse.hs view
@@ -2,7 +2,7 @@ import Syntax import Text.ParserCombinators.Parsec hiding (spaces)-import Util.Monad +import My.Control.Monad import Data.Maybe parseAlpha file s = lazyMany axiom file s@@ -30,22 +30,25 @@ -- Productions axiom = free boundExpr -atom = (:[]) $< symbol <|> paren+atom = (\x -> [x]) $< symbol <|> parGroup wrap beg g end = between (string beg) (string end) g-paren = wrap "(" (inParen wrParen) ")"+parGroup = wrap "(" (inParen wrParen) ")" <|> wrap "[" (inParen mkNode) "]" <|> wrap "{" (inParen concat) "}" inParen wr = wr $< (oWhite >> looseExpr`endBy`oWhite) +chain expr op e = (do o <- try op+ e' <- expr+ chain expr op (o e e'))+ <|> return e+ looseExpr = (<?>"loose expression") $ concat $< (boundExpr `sepBy1` free (oneOf ",;")) boundExpr = (<?>"bound expression") $ wrParen $< (infExpr `sepBy1` free (char '_'))-infExpr = (<?>"infix expression") $ foldl fun $< tightExpr >$< many tl - where fun e (Left f) = [Group $ f++e]- fun e (Right (o,e')) = [Group $ o++e++e']- opExpr = (<?>"operator expression") $ concat $< many1 atom- tl = (free (char '.') >> Left $< opExpr)- <|> (free (char ':') >> Right $< ((,) $< opExpr >$< (oWhite >> tightExpr)))+infExpr = (<?>"infix expression") $ chain (return ()) op =<< tightExpr+ where opExpr = (<?>"operator expression") $ concat $< many1 atom+ op = (free (char '.') >> liftM (\o e _ -> [Group $ o++e]) opExpr)+ <|> (free (char ':') >> liftM2 (\o e' e _ -> [Group $ o++e++e']) opExpr (oWhite >> tightExpr)) tightExpr = (<?>"close expression") $ wrParen $< many1 atom symbol = Symbol $< ((string <?> "string") <|> (symbol <?> "symbol"))@@ -71,5 +74,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Translate.hs view
@@ -1,33 +1,35 @@ module Translate where -import Util.Monad+import My.Control.Monad import Data.Bimap as BM-import Util.ID-import IR-import Environment.Value as E+import ID+import PCode+import Context.Types as C -class Translate t where+class Translatable t where translate :: (ID -> ID) -> t -> t -instance Translate ID where+instance Translatable ID where translate = ($)-instance Translate IDRange where+instance Translatable IDRange where translate t (IDRange (a,b)) = IDRange (t a,t b)-instance Translate e => Translate [e] where +instance Translatable e => Translatable [e] where translate tr l = map (translate tr) l-instance Translate E.Value where - translate tr (Verb args ret code) = Verb (translate tr args) (translate tr ret) (translate tr code)- translate tr (Noun ret init) = Noun (translate tr ret) (translate tr init)+instance Translatable C.Value where + translate tr (Verb code) = Verb (translate tr code)+ translate tr (Noun size init) = Noun (translate tr size) (translate tr init) translate tr x = x-instance Translate Instruction where+instance Translatable Instruction where translate tr (Op b v vs) = Op b (translate tr v) (translate tr vs) translate tr (Branch v as) = Branch (translate tr v) as translate tr (Bind bv v) = Bind (translate tr bv) (translate tr v) translate tr Noop = Noop-instance Translate IR.Value where+instance Translatable PCode.Value where translate tr (SymVal t id) = SymVal t (translate tr id) translate tr v = v-instance Translate BindVar where+instance Translatable Code where+ translate tr (Code args code ret) = Code (translate tr args) (translate tr code) (translate tr ret)+instance Translatable BindVar where translate tr (BindVar id s pad subs) = BindVar (translate tr id) s pad [(translate tr bv,s) | (bv,s) <- subs] -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com>@@ -38,5 +40,5 @@ -- 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.+-- 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 DPCodeECT, INDPCodeECT, 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/Util/Graph.hs
@@ -1,89 +0,0 @@-module Util.Graph( - Context,Graph,Node(..),- - empty,- lookupContext,getContext,- insertNode,deleteNode,modifyNode,- insertEdge,deleteEdge,- - modifyInEdges,modifyOutEdges,- tag,inEdges,outEdges,edges,- nextNodes,prevNodes,- - nodeList,nodeListFull,- - mapNodes- )- where--import qualified Data.Map as M-import Data.List-import Data.Maybe--type Node = Int-data Context e n = Context { - nodeTag :: n, - nodeInEdges :: M.Map Node e, - nodeOutEdges :: M.Map Node e- } deriving Show-data Graph e n = Graph {- nbNodes :: Int,- graphNodes :: M.Map Node (Context e n)- }- -empty = Graph 0 M.empty--lookupContext n (Graph _ nds) = M.lookup n nds-getContext n g = fromMaybe (error $ "No node "++show n++" in graph "++show g) $ lookupContext n g--insertNode x (Graph n nds) = (n,Graph (n+1) (M.insert n (Context x M.empty M.empty) nds))-deleteNode nd (Graph n nds) = Graph n (M.delete nd nds)-modifyNode nd f (Graph n nds) = Graph n (M.adjust (\(Context t i o) -> Context (f t) i o) nd nds)--insertEdge x n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.insert n1 x)) n2 $- M.adjust (modifyOutEdges (M.insert n2 x)) n1 nds) -deleteEdge n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.delete n1)) n2 $- M.adjust (modifyOutEdges (M.delete n2)) n1 nds)--modifyInEdges f c = c { nodeInEdges = f $ nodeInEdges c }-modifyOutEdges f c = c { nodeOutEdges = f $ nodeOutEdges c }--tag = nodeTag-inEdges = M.toList . nodeInEdges-outEdges = M.toList . nodeOutEdges-edges c = (inEdges c,outEdges c)--nextNodes = map fst . outEdges-prevNodes = map fst . inEdges--nodeList = map fst . nodeListFull-nodeListFull = M.toList . graphNodes--mapNodes f (Graph n nds) = Graph n (M.mapWithKey (\n (Context t ie oe) -> Context (f n t) ie oe) nds)--instance Functor (Graph e) where- fmap f = mapNodes (const f)-instance (Show n,Show e) => Show (Graph e n) where- show (Graph _ nds) = intercalate "\n" showNodes- where showNodes = map showNode $ M.toList nds- showNode (n,Context nd ie oe) = - show n++": "++show nd++"\n "++- intercalate "\n " (map showNEdge (M.toList oe)- ++ map showREdge (M.toList ie))- where showNEdge (n',e) = "--"++show e++"--> "++show n'- showREdge (n',e) = "<--"++show e++"-- "++show n'- - - ----- 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/Util/ID.hs
@@ -1,35 +0,0 @@-module Util.ID where--newtype ID = ID Int- deriving (Ord,Eq)-newtype IDRange = IDRange (ID,ID)- deriving Show- -singleRange i = IDRange (i,i)--instance Eq IDRange where- a == b = compare a b == EQ-instance Ord IDRange where- compare (IDRange (a,b)) (IDRange (a',b')) = - if b<=a' then LT- else if b'<=a then GT- else EQ--instance Enum ID where- toEnum = ID- fromEnum (ID i) = i-instance Show ID where- show (ID i) = "x"++show i------ 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/Util/List.hs
@@ -1,21 +0,0 @@-module Util.List(module Data.List,classesBy,nubOrd) where--import Data.List--nubOrd :: Ord a => [a] -> [a]-nubOrd = map head . group . sort--classesBy :: (a -> a -> Bool) -> [a] -> [[a]]-classesBy (==) [] = []-classesBy (==) (e:l) = let (x,t) = partition (e==) l in (e:x):classesBy (==) t---- 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/Util/Monad.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module Util.Monad (module Control.Monad,($<),(>$),(>$<),(<&&>),(<||>),ifM,findM,traverseM) where--import Control.Monad-import Data.Traversable-import Control.Applicative--($<) :: Monad m => (a -> b) -> m a -> m b-(>$) :: Monad m => m (a -> b) -> a -> m b-(>$<) :: Monad m => m (a -> b) -> m a -> m b-($<) = liftM-mf >$ x = mf >>= \f -> return (f x)-(>$<) = ap- -ifM b th el = b >>= \b -> if b then th else el-a <&&> b = ifM a b (return False)-a <||> b = ifM a (return True) b--findM p l = foldr fun (return Nothing) l- where fun x ret = ifM (p x) (return $ Just x) ret--traverseM f = unwrapMonad . traverse (WrapMonad . f)---- 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/Util/Prelude.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module Util.Prelude where--import System.Posix.Files-import Data.Maybe-import Debug.Trace-import Util.Monad--debug x = traceShow x x--maybeToEither = maybe (Left undefined) Right-eitherToMaybe = either (const Nothing) Just--ifThenElse b th el = if b then th else el--swap (a,b) = (b,a)--newerThan f1 f2 = liftM2 (>) (modTime f1) (modTime f2)- where modTime f = modificationTime $< getFileStatus f----- 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/Util/State.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE TupleSections #-}--module Util.State(- module Control.Monad.State, - Field(..),(<.>),- stateF,doF,modifyF,getF,getsF,putF,swapF,- fstF,sndF- ) where--import Control.Monad.State--type Field f s = (s -> f,f -> s -> s)--stateF :: Field f s -> (f -> (a,f)) -> State s a-modifyF :: Field f s -> (f -> f) -> State s ()-getF :: Field f s -> State s f-getsF :: Field f s -> (f -> a) -> State s a-putF :: Field f s -> f -> State s ()-swapF :: Field f s -> f -> State s f-(<.>) :: Field f s -> Field g f -> Field g s--fstF :: Field a (a,b)-sndF :: Field b (a,b)--fstF = (fst,(\x (a,b) -> (x,b)))-sndF = (snd,(\y (a,b) -> (a,y)))--stateF (m,m') st = state (\s -> let (v,st') = st (m s) in (v,m' st' s))-doF f st = stateF f (runState st)-modifyF fld f = stateF fld (\s -> ((),f s))-getF (f,_) = gets f -getsF (f,_) g = gets (g . f)-putF f v = modifyF f (const v)-swapF f v = stateF f (,v) --(f,f') <.> (g,g') = (g . f, (\g s -> f' (g' g (f s)) s)) ---- 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/Util/TimeLine.hs
@@ -1,48 +0,0 @@-module Util.TimeLine where--import Util.Monad-import Util.State--newtype TimeLine p f a = TimeLine { runTimeLine :: (p,f) -> [(p,f,a)] }--instance Monad (TimeLine p f) where- tl >>= cc = TimeLine tl'- where tl' (p,f) = map snd lb- where la = runTimeLine tl (p,f')- lb@((f',_):_) = [(f',(p'',f'',b))- | (p',f'',a) <- la- , (p'',f',b) <- runTimeLine (cc a) (p',f)]- return a = TimeLine (\(p,f) -> [(p,f,a)])--fork = TimeLine (\(p,f) -> [(p,f,True),(p,f,False)])--statetl = TimeLine . \k st -> let (a,(p,f)) = k st in [(p,f,a)]-runtl = statetl . runState--statep = runtl . stateF fstF-runp = statep . runState-getp = runp get-getsp = runp . gets-modifyp = runp . modify-setp = modifyp . const--statef = runtl . stateF sndF-runf = statef . runState-getf = runf get-getsf = runf . gets-modifyf = runf . modify-setf = modifyf . const--(swapplytl,swapplyp,swapplyf) = (f statetl,f statep,f statef)- where f st m = st (\x -> (x,m x))---- 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 view
@@ -0,0 +1,60 @@+#include <unistd.h>+#include <libelf.h>+#include "writeElf.h"++#define SETSTRUCT(v,t,vals...) { t tmp = vals; v = tmp; }++void writeElf(int fd,byte* data,int dataSize) {+ Elf64_Ehdr eh; Elf64_Phdr pht[1];+ unsigned int hSize = sizeof(eh) + sizeof(pht);++ 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 = 0,+ .e_phoff = sizeof(Elf64_Ehdr),+ .e_shoff = 0,+ .e_flags = 0,+ .e_ehsize = sizeof(Elf64_Ehdr),+ .e_phentsize = sizeof(Elf64_Phdr),+ .e_phnum = 2,+ .e_shentsize = 0,+ .e_shnum = 0,+ .e_shstrndx = SHN_UNDEF+ });+ SETSTRUCT(pht[0],Elf64_Phdr,{ .p_type = PT_LOAD,+ .p_offset = hSize,+ .p_vaddr = 0,+ .p_paddr = 0,+ .p_filesz = dataSize,+ .p_memsz = dataSize,+ .p_flags = PF_R | PF_W | PF_X,+ .p_align = 1+ });+ + 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 DPCodeECT, INDPCodeECT, 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. +*/+