diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 0.9.9 +version: 0.9.9.5 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time @@ -20,8 +20,10 @@ location: git://github.com/lih/Alpha.git executable alpha - build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, relation + build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, relation, AvlTree, COrdering main-is: Alpha.hs - other-modules: Alpha, Compile, Compile.State, Compile.Utils, Context, Context.Language, Context.Types, Elf, ID, My.Control.Monad, My.Control.Monad.State, My.Control.Monad.TimeLine, My.Data.Either, My.Data.Graph, My.Data.List, My.Data.Tree, My.Prelude, Options, PCode, PCode.Builtin, PCode.Instruction, PCode.Value, Serialize, Specialize, Specialize.Architecture, Specialize.Types, Specialize.X86_64, Syntax, Syntax.Parse, Translate + other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Elf ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Syntax Syntax.Parse Translate hs-source-dirs: src c-sources: src/writeElf.c + + diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -1,29 +1,29 @@ {-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, ParallelListComp #-} -import System.Environment as SE -import System.FilePath -import System.Directory -import System.Posix.Files -import Foreign hiding (void) -import Data.Ord +import Compile +import Context +import Data.ByteString.Unsafe +import Data.List import Data.Maybe -import qualified Data.Map as M +import Data.Ord import qualified Data.Bimap as BM -import qualified Data.Serialize as Ser import qualified Data.ByteString as B -import Data.ByteString.Unsafe -import Data.List +import qualified Data.Map as M +import qualified Data.Serialize as Ser +import Elf (writeElf) +import Foreign hiding (void) import My.Control.Monad import My.Control.Monad.State hiding ((<.>)) import My.Prelude import Options -import Elf (writeElf) -import Syntax -import Syntax.Parse -import Compile +import PCode import Serialize import Specialize -import Context -import PCode +import Syntax +import Syntax.Parse +import System.Directory +import System.Environment as SE +import System.FilePath +import System.Posix.Files main = do args <- getArgs @@ -35,48 +35,48 @@ PrintHelp -> printHelp PrintVersion -> printVersion Compile -> print s >> doCompile s - -version = "0.9.8" + +version = "0.9.9" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version - + newtype Str = Str String instance Show Str where show (Str s) = s -doTestOlder = return True -- for testing purposes, turn makefile-style file dependencies on or off +doTestOlder = return True -- for testing purposes, turn makefile-style file dependencies checks on or off -doCompile opts = case programs opts of +doCompile opts = case programs opts of [] -> interactive progs -> mapM_ compileProgram progs - where + where languageFile language = languageDir optslanguage<.>"l" findSource language = findM doesFileExist (concat [[base<.>"a",base] | dir <- sourceDirs opts , let base = dirlanguage]) readProg s = let (a,':':b) = break (==':') s in (a,b) - - interactive = void $ compileFile "/dev/stdin" + + interactive = void $ compileFile "/dev/stdin" compileProgram (readProg -> (language,root)) = withDefaultContext $ do importLanguage compileLanguage (const $ return ()) language rootSym <- stateF languageF $ internSym root getAddressComp (outputArch opts) rootSym (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses top <- gets compTop - contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) + contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs] writeElf language contents compileLanguage name = debugM $ do source <- fromMaybe (error $ "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 + if b then either error id $< Ser.decode $< B.readFile langFile else do putStrLn $ "Compiling language "++name lang <- compileFile source createDirectoryIfMissing True (dropFileName langFile) B.writeFile langFile (Ser.encode lang) return lang loadLanguage name = compileLanguage name >>= execCode . initializeL >> languageState get - - compileFile src = withDefaultContext $ (>> gets language) $ do + + compileFile src = withDefaultContext $ (>> gets language) $ do str <- readFile src let sTree = concat $ parseAlpha src str code <- mapM compileExpr sTree @@ -87,16 +87,6 @@ trExpr <- doTransform symExpr (code,imports) <- languageState $ compile Nothing trExpr mapM_ (importLanguage compileLanguage (execCode . initializeL)) imports - execCode code + execCode code return code - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/Compile.hs b/src/Compile.hs --- a/src/Compile.hs +++ b/src/Compile.hs @@ -17,16 +17,16 @@ compile dest expr = runStateT st defaultState >§ \(code,cs) -> (code,imports cs) where st = do - (_,(start,_)) <- compile' dest expr - simplify start >>= linearize - + (_,(start,_)) <- compile' dest expr + simplify start >>= linearize >>= lift . uniquify + compile' dest (Symbol sym) = do name <- getSymName sym let def = SymVal Value sym val = fromMaybe def (IntVal $< (readConstant =<< name)) - fromMaybe (nullCodeVal val) $ do + fromMaybe (nullCodeVal val) $ do v <- dest - guard (not $ v `varEqVal` val) + guard (not $ v `varEqVal` val) return $ do n <- createNode (Instr $ set v val) return (def,singleCode n) compile' dest (Group (Symbol id:args)) = do @@ -38,36 +38,35 @@ compile dest args compile' dest (Group args) = compileCall dest args -compileBy op dest args = do +compileBy op dest args = do (vars,code) <- unzip $< mapM (compile' Nothing) args dest <- maybe newVar return dest n <- createNode (Instr $ op dest vars) sequence_ [createEdge TimeDep n' n | (_,l) <- code, n' <- l] return (SymVal Value dest,(n:concatMap fst code,[n])) -compileBuiltin = compileBy . simplify - where simplify op dest [] = Op BSet dest [IntVal 0] - simplify op dest vars = Op op dest vars +compileBuiltin _ _ [] = nullCodeVal (IntVal 0) +compileBuiltin b dest args = compileBy (Op b) dest args compileCall = compileBuiltin BCall compileAxiom XAlter _ forms = do let (vars,exprs) = partitionEithers $ zipWith ($) (cycle [Left,Right]) forms - codes <- sequence [compile' (Just v) e | Symbol v <- vars | e <- exprs] + codes <- sequence [compile' (Just v) e | Symbol v <- vars | e <- exprs] let (starts,ends) = unzip $ map snd codes return (NullVal,(concat starts,concat ends)) compileAxiom XBind _ args = case args of [bVars] -> doBind bVars Nothing [bVars,expr] -> do - v <- newVar + v <- newVar compile' (Just v) expr *>> doBind bVars (Just v) - where - doBind bVars val = do + where + doBind bVars val = do bnd <- bindFromSyntax bVars n <- createNode (Instr $ PCode.Bind bnd val) return (NullVal,singleCode n) - + compileAxiom XDo dest [] = nullCode -compileAxiom XDo dest forms = do +compileAxiom XDo dest forms = do let cs = reverse $ zipWith compile' (dest:repeat Nothing) (reverse forms) foldr1 (*>>) cs compileAxiom XChoose dest (cond:forms) = do @@ -75,22 +74,22 @@ alts <- replicateM (length forms) mkNoop v <- maybe newVar return dest let dest = Just v - + withTopInfo (start,alts,end,dest) $ do - return (NullVal,singleCode start) + return (NullVal,singleCode start) *>> compile' Nothing cond *>>= \cv -> do let code = zipWith compile' (repeat dest) forms fun alt code = return (NullVal,singleCode alt) *>> code *>> makeBranch NullVal [end] - sequence_ $ zipWith fun alts code - makeBranch cv alts + sequence_ $ zipWith fun alts code + makeBranch cv alts return (SymVal Value v,([start],[end])) compileAxiom XReturn dest [arg] = withInfo $ \(_,_,end,dest) -> compile' dest arg *>> makeBranch NullVal [end] - + compileAxiom XRestart _ [] = withInfo $ \(start,_,_,_) -> makeBackBranch NullVal [start] -compileAxiom XRestart _ [arg] = withInfo $ \(_,alts,_,_) -> +compileAxiom XRestart _ [arg] = withInfo $ \(_,alts,_,_) -> compile' Nothing arg *>>= \v -> makeBackBranch v alts compileAxiom XVerb dest [Group (name:args),expr] = do @@ -106,7 +105,7 @@ (retInit,codeInit) <- compileExpr init lift $ modify $ exportSymVal sym $ Noun (Code [] codeSz (symBind retSz)) (Code [symBind sym] codeInit (symBind retInit)) compile' dest (Symbol sym) - + compileAxiom XLang _ [Symbol s] = do getSymName s >>= maybe (return()) (modify . (\n e -> e { imports = n:imports e })) nullCode @@ -134,27 +133,17 @@ bindFromSyntax (Symbol v) = return $ symBind v bindFromSyntax (Group (Symbol v:t)) = do - let fun (ns,l) (Symbol v) = getSymName v >>= \s -> + let fun (ns,l) (Symbol v) = getSymName v >>= \s -> maybe (fun' ns l (Symbol v)) (\n -> return (n:ns,l)) (readConstant =<< s) - fun (ns,l) e = fun' ns l e + fun (ns,l) e = fun' ns l e fun' ns l e = do b <- bindFromSyntax e return ([],(b,product ns):l) - + (pads,subs) <- foldM fun ([],[]) $ reverse t let size = foldl (<+>) (pad,0) $ [(n*a,n*b) | (BindVar _ (a,b) _ _,n) <- subs] pad = if null pads then 0 else product pads (a,b) <+> (a',b') = (a+a',b+b') return $ BindVar v size pad subs bindFromSyntax s = error $ "Invalid shape for bindVar : "++show s - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/Compile/State.hs b/src/Compile/State.hs --- a/src/Compile/State.hs +++ b/src/Compile/State.hs @@ -111,15 +111,3 @@ instance Show NodeData where show (Instr i) = show i show (BrPart v) = "case "++show v - - --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/Compile/Utils.hs b/src/Compile/Utils.hs --- a/src/Compile/Utils.hs +++ b/src/Compile/Utils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TupleSections, ViewPatterns, NoMonomorphismRestriction #-} - module Compile.Utils where import Compile.State as CS @@ -8,6 +7,7 @@ import My.Control.Monad import My.Control.Monad.State import My.Data.List +import My.Data.Tree import qualified Data.Map as M import qualified Data.Set as S @@ -15,8 +15,20 @@ import PCode import Syntax +import Translate + import Debug.Trace +uniquify [] = return [] +uniquify code = flatten $< descendM desc M.empty $ spanningTree 0 nexts + where (_,instr,nexts,_) = navigate code + desc (instr -> Bind bv v) m = do + news <- mapM (const $ state createSym) (bindSyms bv) + let m' = debug $ foldr (uncurry M.insert) m (zip (bindSyms bv) news) + return (Bind (translate (translateBy m') bv) (fmap (translateBy m) v),m') + desc i m = return (translate (translateBy m) (instr i),m) + translateBy m s = fromMaybe s $ M.lookup s m + simplify :: Monad m => [Node] -> StateT CompileState m [Node] simplify start = do oldDep <- getF depGraphF ; purgeAll ; newDep <- getF depGraphF @@ -120,16 +132,4 @@ , let t = tag $ G.getContext n' newdepG] maximum = foldl max 0 - - - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -8,7 +8,7 @@ import System.IO.Unsafe (unsafePerformIO) import Bindings.Posix.Sys.Mman -import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr) +import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) import Foreign.C import Foreign.ForeignPtr.Unsafe import Data.Maybe @@ -28,7 +28,7 @@ import Syntax import Specialize.Architecture -foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt +foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x @@ -45,16 +45,16 @@ 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), - + ("noun" ,Left $ Axiom XNoun), + ("id" ,Left $ Axiom XID), ("@" ,Left $ Axiom XAddr), ("#" ,Left $ Axiom XSize)] ++ [ @@ -63,10 +63,10 @@ doTransform syn = gets transform >>= ($syn) -initialContext = C lang jitA M.empty entryAddress return +initialContext = C lang jitA M.empty (fromIntegral entryAddress) return where (lang,jitA) = execState (mapM_ st initialBindings) (empty,M.empty) where st (s,v) = do - i <- stateF fstF (internSym s) + 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) @@ -79,36 +79,35 @@ 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 - putStrLn $ "Evaluating code "++show code - unsafeUseAsCStringLen binary $ \(p,s) -> do - mprotect (castPtr p) (fromIntegral s) (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC) - return $ wrap $ castPtrToFunPtr p -execCode [] = return () -execCode instrs = do - id <- languageState $ state createSym - join $ evalCode mkProc (Code [] instrs (symBind id)) getAddress arch lookup register = withRef addressRef getAddr . getAddr - where + 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 + Verb c -> void $ do + let (size,codem) = specialize arch (id,getAddr) c ptr <- mallocForeignPtrBytes size - register id ptr size + register id ptr size code <- codem - withForeignPtr ptr $ \p' -> unsafeUseAsCStringLen code $ \(p,n) -> copyBytes p' (castPtr p) n + withForeignPtr ptr $ \p -> do + unsafeUseAsCStringLen code $ \(p',n) -> copyBytes p (castPtr p') n + mprotect (castPtr p) (fromIntegral size) (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC) 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) - + +evalCode :: (FunPtr f -> f) -> Code -> IO f +evalCode wrap code = do + id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i + p <- getAddressJIT id + return $ wrap $ castPtrToFunPtr $ intPtrToPtr $ fromIntegral p +execCode [] = return () +execCode instrs = join $ evalCode mkProc (Code [] instrs (symBind (ID (-1)))) + getAddressJIT = getAddress hostArch lookup register where lookup id = do val <- M.lookup id $< gets jitAddresses @@ -117,17 +116,7 @@ getAddressComp arch = getAddress arch lookup register where lookup id = (fst$<) $< M.lookup id $< gets compAddresses register id ptr size = do - n <- getF compTopF + n <- getF compTopF modifyF compAddressesF (M.insert id (n,ptr)) modifyF compTopF (+size) - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/Context/Language.hs b/src/Context/Language.hs --- a/src/Context/Language.hs +++ b/src/Context/Language.hs @@ -106,13 +106,3 @@ references (Noun size init) = codeRefs size ++ codeRefs init references _ = [] --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/Context/Types.hs b/src/Context/Types.hs --- a/src/Context/Types.hs +++ b/src/Context/Types.hs @@ -10,10 +10,10 @@ import PCode import Syntax -data Axiom = XAlter | XBind +data Axiom = XAlter | XBind | XReturn | XRestart | XChoose | XDo | XLang | XVerb | XNoun - | XID | XAddr | XSize + | XID | XAddr | XSize deriving Show data Value = Axiom Axiom @@ -47,5 +47,3 @@ compAddressesF = Field (compAddresses,\a c -> c { compAddresses = a }) languageF = Field (language,\a c -> c { language = a }) compTopF = Field (compTop,\a c -> c { compTop = a }) - - diff --git a/src/Elf.hs b/src/Elf.hs --- a/src/Elf.hs +++ b/src/Elf.hs @@ -22,13 +22,3 @@ unsafeUseAsCStringLen dat (\(d,nd) -> c_writeElf (fromIntegral fd) d (fromIntegral nd)) --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/ID.hs b/src/ID.hs --- a/src/ID.hs +++ b/src/ID.hs @@ -28,13 +28,3 @@ signum = undefined fromInteger n = ID $ fromInteger n --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/My/Control/Monad.hs b/src/My/Control/Monad.hs --- a/src/My/Control/Monad.hs +++ b/src/My/Control/Monad.hs @@ -1,7 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -module My.Control.Monad (module Control.Monad,($<),(>$),(>$<),(§),(§<),(>§),(>§<),(<&&>),(<||>),ifM,findM) where +module My.Control.Monad (module Control.Monad,($<),(>$),(>$<),(§),(§<),(>§),(>§<),(<&&>),(<||>),ifM,findM,lift2) where import Control.Monad +import Control.Monad.Trans ($<) :: Monad m => (a -> b) -> m a -> m b (>$) :: Monad m => m (a -> b) -> a -> m b @@ -9,11 +10,15 @@ ($<) = liftM mf >$ x = mf >>= \f -> return (f x) (>$<) = ap - + +lift2 = lift . lift + +infixr 0 $<,>$,>$< + (§) = flip ($) (§<) = flip (>$) (>§) = flip ($<) -(>§<) = flip (>$<) +(>§<) = flip (>$<) ifM b th el = b >>= \b -> if b then th else el a <&&> b = ifM a b (return False) @@ -23,14 +28,4 @@ findM p l = foldr fun (return Nothing) l where fun x ret = ifM (p x) (return $ Just x) ret - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/My/Control/Monad/RWTL.hs b/src/My/Control/Monad/RWTL.hs new file mode 100644 --- /dev/null +++ b/src/My/Control/Monad/RWTL.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} +module My.Control.Monad.RWTL(RWTL(..),module Data.Monoid + ,fst4,snd4,thd4,fth4 + ,get,put + ,ask,local + ,tell,listen,pass,listening + ,future) where + +import Data.Monoid +import Control.Monad.State +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class + +newtype RWTL r w p f a = RWTL { runRWTL :: r -> p -> f -> (p,f,a,w) } + +fst4 (a,_,_,_) = a +snd4 (_,a,_,_) = a +thd4 (_,_,a,_) = a +fth4 (_,_,_,a) = a + +instance Monoid w => Monad (RWTL r w p f) where + rw >>= cc = RWTL rw' + where rw' r p f = (p'',f'',b,w`mappend`w') + where (p',f'',a,w) = runRWTL rw r p f' + (p'',f',b,w') = runRWTL (cc a) r p' f + return a = RWTL (\r p f -> (p,f,a,mempty)) + +class MonadFuture f m | m -> f where + future :: (State f a) -> m a + +instance Monoid w => MonadState p (RWTL r w p f) where + get = RWTL (\_ p f -> (p,f,p,mempty)) + put p = RWTL (\_ _ f -> (p,f,(),mempty)) +instance Monoid w => MonadReader r (RWTL r w p f) where + ask = RWTL (\r p f -> (p,f,r,mempty)) + local l (RWTL rw) = RWTL (rw . l) +instance Monoid w => MonadWriter w (RWTL r w p f) where + tell w = RWTL (\_ p f -> (p,f,(),w)) + listen (RWTL rw) = RWTL (\r p f -> let (p',f',a,w) = rw r p f in (p',f',(a,w),w)) + pass (RWTL rw) = RWTL (\r p f -> let (p',f',(a,m),w) = rw r p f in (p',f',a,m w)) +instance Monoid w => MonadFuture f (RWTL r w p f) where + future st = RWTL (\r p f -> let ~(a,f') = runState st f in (p,f',a,mempty)) + +listening m = censor (const mempty) $ do (_,w) <- listen m ; return w diff --git a/src/My/Control/Monad/State.hs b/src/My/Control/Monad/State.hs --- a/src/My/Control/Monad/State.hs +++ b/src/My/Control/Monad/State.hs @@ -11,10 +11,10 @@ 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) +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 +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 @@ -25,14 +25,4 @@ 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 --- 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. diff --git a/src/My/Control/Monad/TimeLine.hs b/src/My/Control/Monad/TimeLine.hs deleted file mode 100644 --- a/src/My/Control/Monad/TimeLine.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# 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 --- 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. - diff --git a/src/My/Data/Either.hs b/src/My/Data/Either.hs --- a/src/My/Data/Either.hs +++ b/src/My/Data/Either.hs @@ -1,7 +1,9 @@ -module My.Data.Either (module Data.Either, fromLeft, fromRight, fromEither) where +module My.Data.Either (module Data.Either, fromLeft, fromRight, fromEither, isLeft) where import Data.Either fromLeft = either id (error "fromLeft given a Right argument") fromRight = either (error "fromRight given a Left argument") id fromEither x = either (const x) id + +isLeft = either (const True) (const False) diff --git a/src/My/Data/Graph.hs b/src/My/Data/Graph.hs --- a/src/My/Data/Graph.hs +++ b/src/My/Data/Graph.hs @@ -71,13 +71,3 @@ where showNEdge (n',e) = "--"++show e++"--> "++show n' showREdge (n',e) = "<--"++show e++"-- "++show n' --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/My/Data/List.hs b/src/My/Data/List.hs --- a/src/My/Data/List.hs +++ b/src/My/Data/List.hs @@ -1,4 +1,4 @@ -module My.Data.List(module Data.List,classesBy,nubOrd,sums) where +module My.Data.List(module Data.List,classesBy,nubOrd,sums,zipRest) where import Data.List @@ -10,15 +10,7 @@ classesBy (==) (e:l) = let (x,t) = partition (e==) l in (e:x):classesBy (==) t sums :: Num a => [a] -> [a] -sums = scanl (+) 0 - --- Copyright (c) 2012, Coiffier Marc --- 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. +sums = scanl (+) 0 --- 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. +zipRest l l' = (zip l l',drop (length l) l') diff --git a/src/My/Data/SetBy.hs b/src/My/Data/SetBy.hs new file mode 100644 --- /dev/null +++ b/src/My/Data/SetBy.hs @@ -0,0 +1,45 @@ +module My.Data.SetBy (SetBy + ,empty,fromList,fromAscList + ,null + ,toList,toAscList + ,insert,delete,member + ,findMin + ,partition + ,union) where + +import Prelude hiding (null) +import qualified Data.Tree.AVL as AVL +import Data.COrdering +import Data.Maybe +import qualified Data.List as L + +data SetBy a = SetBy { + cmpFunc :: a -> a -> COrdering a, + tree :: AVL.AVL a + } + +instance Show a => Show (SetBy a) where + show (SetBy _ t) = case AVL.asListL t of + [] -> "empty" + l -> "fromList "++show l + +empty cmp = SetBy (fstByCC cmp) AVL.empty +fromList cmp l = fromAscList cmp (L.sortBy cmp l) +fromAscList = fromAscList' . fstByCC +fromAscList' cmp l = SetBy cmp (AVL.asTreeL l) + +null = AVL.isEmpty . tree + +toList = toAscList +toAscList (SetBy _ t) = AVL.asListL t + +insert e (SetBy cmp t) = SetBy cmp (AVL.push (cmp e) e t) +delete e (SetBy cmp t) = SetBy cmp (fromMaybe t $ fmap snd $ AVL.tryPop (cmp e) t) +member e (SetBy cmp t) = isJust $ AVL.tryRead t (cmp e) + +findMin (SetBy _ t) = AVL.assertReadL t + +partition p s@(SetBy c t) = (fromAscList' c a,fromAscList' c b) + where ~(a,b) = L.partition p $ toAscList s + +union (SetBy c t) (SetBy _ t') = SetBy c (AVL.union c t t') diff --git a/src/My/Data/Tree.hs b/src/My/Data/Tree.hs --- a/src/My/Data/Tree.hs +++ b/src/My/Data/Tree.hs @@ -1,10 +1,11 @@ module My.Data.Tree(module Data.Tree ,nubT,iterateT ,spanningTree - ,branches, nodeList) where + ,branches, nodeList + ,descend, descendM) where import Data.Tree -import Data.Set as S +import qualified Data.Set as S import Control.Monad.State nubT t = evalState (unfoldTreeM unfold t) S.empty @@ -20,5 +21,9 @@ nodeList n@(Node _ subs) = n:concatMap nodeList subs -test = Node 1 [Node 2 [Node 3 [],Node 4 []], - Node 5 [Node 6 [],Node 7 []]] +descend f s (Node e subs) = Node e' (map (descend f s') subs) + where (e',s') = f e s +descendM f s (Node e subs) = do + (e',s') <- f e s + subs <- mapM (descendM f s') subs + return $ Node e' subs diff --git a/src/My/Prelude.hs b/src/My/Prelude.hs --- a/src/My/Prelude.hs +++ b/src/My/Prelude.hs @@ -7,7 +7,8 @@ import My.Control.Monad debug x = traceShow x x -debugM m = m >>= \x -> return (debug x) +debugM = liftM debug +trace = Debug.Trace.trace maybeToEither = maybe (Left undefined) Right eitherToMaybe = either (const Nothing) Just @@ -15,18 +16,10 @@ ifThenElse b th el = if b then th else el swap (a,b) = (b,a) +thd (_,_,a) = a +lazyPair ~(a,b) = (a,b) + newerThan f1 f2 = liftM2 (>) (modTime f1) (modTime f2) where modTime f = modificationTime $< getFileStatus f - - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -56,13 +56,3 @@ handleOpt s (LanguageDir d) = s { languageDir = d } handleOpt s (Architecture a) = s { outputArch = a } --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/PCode.hs b/src/PCode.hs --- a/src/PCode.hs +++ b/src/PCode.hs @@ -7,13 +7,3 @@ import PCode.Instruction import PCode.Value --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/PCode/Builtin.hs b/src/PCode/Builtin.hs --- a/src/PCode/Builtin.hs +++ b/src/PCode/Builtin.hs @@ -8,18 +8,10 @@ | BSet deriving (Show,Eq) +isBinOp b = b/=BCall && b/=BSet && b/=BNot + bNames = [(BAdd,"+"),(BMul,"*"),(BSub,"-"),(BDiv,"/"),(BMod,"%"), (BLowerThan,"<"),(BGreaterThan,">"),(BLowerEq,"<="),(BGreaterEq,">="), (BEqual,"=="),(BNotEqual,"<>"), (BAnd,"&"),(BOr,"|"),(BXor,"x|"),(BNot,"not")] - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/PCode/Instruction.hs b/src/PCode/Instruction.hs --- a/src/PCode/Instruction.hs +++ b/src/PCode/Instruction.hs @@ -99,13 +99,3 @@ padStr = if pad==0 then [] else [show pad] subsStr = map show subs --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/PCode/Value.hs b/src/PCode/Value.hs --- a/src/PCode/Value.hs +++ b/src/PCode/Value.hs @@ -34,14 +34,3 @@ show (IntVal n) = show n show NullVal = "(null)" - --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/Serialize.hs b/src/Serialize.hs --- a/src/Serialize.hs +++ b/src/Serialize.hs @@ -39,13 +39,3 @@ instance Serialize Language --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/Specialize.hs b/src/Specialize.hs --- a/src/Specialize.hs +++ b/src/Specialize.hs @@ -1,98 +1,109 @@ {-# LANGUAGE RankNTypes, ParallelListComp, TupleSections #-} module Specialize(specialize) where -import Data.Monoid -import Control.Arrow import Context.Types +import Control.Arrow import Control.Monad.Trans.Reader import Data.Array -import Data.List import Data.Maybe -import Data.Word +import Data.Monoid import Data.Ord -import qualified Data.ByteString as B -import qualified Data.Map as M -import qualified Data.Relation as R -import qualified Data.Set as S +import Data.Word import ID import My.Control.Monad import My.Control.Monad.State -import My.Control.Monad.TimeLine import My.Data.Either +import My.Data.List import My.Data.Tree import PCode import Specialize.Architecture import Specialize.Architecture import Specialize.Types +import qualified Data.ByteString as B +import qualified Data.Map as M +import qualified Data.Relation as R +import qualified Data.Set as S import System.IO.Unsafe import My.Prelude - -retCode = ret - where ret = [0xc3] - exit = [0x31,0xdb - ,0x31,0xc0, 0xff,0xc0 - ,0xcd,0x80] -sums = scanl (+) 0 +import Debug.Trace -specialize arch assoc (Code args code retVar) = foo +specialize arch env (Code args code retVar) = seq (debug instructions') (sum sizes,B.concat $< sequence codes) where - foo = (sum sizes,B.concat $< sequence codes) - -- foo = (length retCode, return (B.pack retCode)) - (estimates,sizes,codes) = unzip3 [v | Right (_,v) <- elems instructions] + ~(estimates,sizes,codes) = unzip3 [v | BC v <- elems instructions] (past,future) = archInitials arch args retVar (bounds,instr,nexts,prevs) = navigate code - positions = listArray bounds [(e,s) | e <- sums estimates, s <- sums sizes] + defSize = archDefaultSize arch + positions = listArray bounds posList + posList = [(e,s) | e <- sums estimates | s <- sums sizes] codeTree = spanningTree 0 nexts - runInstr i (p,f) past = runTimeLine (runReaderT (compile $ instr i) ((infos!i) getPos)) (p,f) + runInstr i p f past = runRWTL (compile $ instr i) ((infos!i) (i,getPos)) p f where compile = archCompileInstr arch - getPos j = (e'-e,d'-d,past j) - where (e,d) = positions!i ; (e',d') = positions!j + getPos j = (e,d,past j) where ~(e,d) = positions!j - treeArray next seed = ret - where assocs = (0,seed):concatMap f (nodeList codeTree) - ret = array bounds assocs - f (Node i subs) = [(j,next j (ret!i) (instr j)) | Node j _ <- subs] + treeArray next seed = array bounds $ flatten $ descend (\i e -> ((i,e),next i e (instr i))) seed codeTree - instructions = execState (specializeTree past codeTree) initialArray + instructions = fmap snd instructions' + instructions' = instrs where - specializeTree p (Node i subs) = gets ((!i) >>> fromLeft) >>= \f -> do - past <- gets (!) - let newVal@(p',_,vals) = runInstr i (p,f) (either (const Nothing) (Just . fst) . past) - modify (// [(i,Right (p,vals))]) - mapM_ (specializeTree p') subs - initialArray = fmap Left init - where init = array bounds (concatMap f $ branches codeTree) - f br = (n,fut):[(i,snd3 $ runInstr j (undefined,init!j) (const Nothing)) | (i,j) <- zip br (tail br)] - where n = last br ; fut = if null (nexts n) then future else emptyFuture - - infos = constA bounds (Info assoc) `applyA` bindingsA `applyA` activesA `applyA` clobbersA - where parent i v = fmap fst $ M.lookup v (bindingsA!i) + getsi f = gets $ \a i -> f (a!i) + puti i e = modify $ (//[(i,e)]) + nextFuture i f = snd4 $ runInstr i undefined f (const Nothing) + gens = array bounds $ zip (flatten codeTree) [0..] + gens' = array bounds $ zip [0..] (flatten codeTree) + getPast g i | g >= gens!i = Just $ fst $ instrs!i + | otherwise = Nothing + instrs = array bounds $ flatten $ descend desc past codeTree + where desc i p = ((i,(p,c)),p') + where ~(p',_,_,c) = runInstr i p (snd $ futures!g!i) (getPast g) + g = gens!i + futures = fmap snd $ listArray bounds $ iterate nextFut (1,initial) + where initial = execState (sequence_ [changeFuture i 0 (futureOf i) | i <- map last (branches codeTree)]) + (constA bounds (-1,undefined)) + where futureOf i | null (nexts i) = future + | otherwise = emptyFuture + nextFut (g,fa) = (g+1,fa') + where fa' = execState (sequence_ [changeFuture i g newFut | i <- prevs instr, head (nexts i)==instr]) fa + instr = gens'!g ; newFut = Future $ registers $ fst (instrs!instr) + changeFuture i g f = puti i (g,f) >> mapM_ propagate (prevs i) + propagate i = do + let j = head (nexts i) + gen <- getsi fst ; fut <- getsi snd + when (gen i < gen j) $ changeFuture i (gen j) (nextFuture j (fut j)) + + infos = constA bounds (Info env) `applyA` bindingsA `applyA` sizesA `applyA` activesA `applyA` clobbersA `applyA` localsA + where root i v = fmap fst $ M.lookup v (bindingsA!i) bindingsA = treeArray next M.empty - where next _ bnd (Bind bv (Just id)) = foldl (\m (k,v) -> M.insert k v m) bnd - [(s,(id,n)) | (s,n,_) <- flattenBind (archDefaultSize arch) bv] + where next _ bnd (Bind bv (Just id)) = insertMany bnd [(s,(id,n)) | (s,n,_) <- flattenBind defSize bv] next _ bnd _ = bnd - activesA = saturate fun prevs nexts init start - where init = accumArray const S.empty bounds [] + sizesA = treeArray next (M.fromList [(s,n) | bv <- retVar:args, (s,_,n) <- flattenBind defSize bv]) + where next _ bnd (Bind bv _) = insertMany bnd [(s,n) | (s,_,n) <- flattenBind defSize bv] + next _ bnd _ = bnd + activesA = fmap snd $ saturate fun prevs nexts init start + where init = listArray bounds (repeat (S.empty,S.empty)) start = concat [prevs i | i <- indices init, isRet (instr i)] - fun i a = addActives (instr i) $ S.unions (map (a!) (nexts i)) - where addActives (Op _ v vs) s = (s S.\\ clobbers i v) + fun i a = (addActives (instr i) out,out) + where out = S.unions (map ((a!) >>> fst) (nexts i)) + addActives (Op _ v vs) s = (s S.\\ clobbers i v) <> S.unions [clobbers i s' | SymVal Value s <- vs - , s' <- s:maybeToList (parent i s)] - <> maybe S.empty (clobbers i) (parent i v) + , s' <- s:maybeToList (root i s)] + <> S.fromList (catMaybes [root i s | SymVal Address s <- SymVal Address v:vs]) addActives (Branch (SymVal Value id) _) s = s <> clobbers i id - addActives (Bind bv v) s = maybe id S.insert v $ s S.\\ S.fromList (bindSyms bv) + addActives (Bind _ v) s = maybe id S.insert v s addActives _ s = s + localsA = treeArray next (S.fromList [v | bv <- retVar:args, v <- bindSyms bv]) + where next _ s (Bind bv _) = s `S.union` S.fromList (bindSyms bv) + next _ s (Op _ v _) = S.insert v s + next _ s _ = s clobbers i v = fromMaybe (S.singleton v) $ R.lookupRan v (clobbersA!i) clobbersA = treeArray next (foldl (next undefined) R.empty [Bind bv Nothing | bv <- retVar:args]) - where next i r (Bind bv v) = insertManyR r' assocs - where r' = restrict r (S.fromList (bindSyms bv)) - assocs = [ass | bv <- bindNodes bv + where next i r (Bind bv v) = insertManyR r assocs + where assocs = [ass | bv <- bindNodes bv , s <- bindSyms bv , ass <- [(bindSym bv,s),(s,bindSym bv)]] ++[ass | v <- maybeToList v , ref <- S.toList $ references i v - , s <- maybe [v] S.toList (R.lookupRan ref r') + , s <- maybe [v] S.toList (R.lookupRan ref r) , ass <- [(s,ref),(ref,s)]] next _ r _ = r lookupRefs v r = fromMaybe (S.singleton (ID (-1))) $ R.lookupRan v r @@ -102,15 +113,13 @@ where r' = S.delete v (R.dom r) R.<| r refs = S.fromList [s | SymVal Address s <- vs] <> S.unions [lookupRefs v r | SymVal Value s <- vs] - next _ r (Bind bv _) = restrict r (S.fromList (bindSyms bv)) next _ r _ = r -restrict r s = (R.dom r S.\\ s) R.<| r R.|> (R.ran r S.\\ s) - constA bs v = accumArray const v bs [] zipWithA f a b = array (bounds a) [(i,f x y) | (i,x) <- assocs a | y <- elems b] applyA = zipWithA ($) insertManyR = foldl (\r (a,b) -> R.insert a b r) +insertMany = foldl (\m (k,v) -> M.insert k v m) saturate fun nexts prevs init start = f init (array (bounds init) [(i,length $ prevs i) | i <- indices init]) start where f a d [] = a diff --git a/src/Specialize/Architecture.hs b/src/Specialize/Architecture.hs --- a/src/Specialize/Architecture.hs +++ b/src/Specialize/Architecture.hs @@ -17,13 +17,3 @@ hostArch = arch_x86_64 { archName = "host" } --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/Specialize/Frame.hs b/src/Specialize/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Specialize/Frame.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ViewPatterns #-} +module Specialize.Frame (Frame,frameAlloc,lookupAddr,emptyFrame,frameTop,withAddr) where + +import qualified Data.Map as M +import PCode +import ID + +data Frame = Frame { + frameTop :: Int, + frameAddrs :: M.Map ID Int + } + deriving Show + +emptyFrame = Frame 0 M.empty + +align n a = case n`mod`a of 0 -> n ; m -> n+a-m +frameAlloc sz bv f = Frame (top+(bSize bv`align`sz)) newAddrs + where bSize (bindSize -> (n,nr)) = n+nr*sz + newAddrs = foldr (uncurry M.insert) (frameAddrs f) [(s,n+top) | (s,n,_) <- flattenBind sz bv] + top = frameTop f +lookupAddr s = M.lookup s . frameAddrs +withAddr sz s f = case lookupAddr s f of + Just a -> (a,f) + Nothing -> (frameTop f,frameAlloc sz (symBind s) f) + diff --git a/src/Specialize/Types.hs b/src/Specialize/Types.hs --- a/src/Specialize/Types.hs +++ b/src/Specialize/Types.hs @@ -1,47 +1,60 @@ {-# LANGUAGE RankNTypes #-} -module Specialize.Types( - module Data.Word, module My.Control.Monad.TimeLine, - module PCode, module ID, - Register(..), - Architecture(..), - Info(..), Past(..),Future(..), - stackF,bindingsF, emptyFuture) where +module Specialize.Types(module Data.Word, module My.Control.Monad.RWTL + ,module PCode, module ID,module Specialize.Frame + ,Register(..),BinCode(..), isEmptyCode + ,Architecture(..) + ,Info(..) + ,MemState(..),Future(..), emptyFuture + ,frameF, registersF) where -import Data.Relation +import Data.Bimap import Data.ByteString +import Data.Map +import Data.Relation +import Data.Set import Data.Word -import My.Control.Monad.TimeLine +import ID import My.Control.Monad.State -import Control.Monad.Trans.Reader +import My.Control.Monad.RWTL import PCode -import ID -import Data.Map -import Data.Set +import Specialize.Frame +newtype BinCode = BC (Int,Int,IO ByteString) +instance Monoid BinCode where + mempty = BC (0,0,return mempty) + mappend (BC ~(e,s,v)) (BC ~(e',s',v')) = BC (e+e',s+s',liftM2 (<>) v v') +instance Show BinCode where + show (BC (e,a,_)) = show (e,a) + +isEmptyCode (BC (e,_,_)) = e==0 + type Register = Int data Architecture = Arch { archName :: String, archDefaultSize :: Int, - archInitials :: [BindVar] -> BindVar -> (Past,Future), - archCompileInstr :: Instruction -> ReaderT Info (TimeLine Past Future) (Int,Int,IO ByteString) + archInitials :: [BindVar] -> BindVar -> (MemState,Future), + archCompileInstr :: Instruction -> RWTL Info BinCode MemState Future () } -data Past = Past { - registers :: Map ID Register, - stackAddrs :: Map ID Int, - stack :: [(Bool,Int)] +data MemState = MemState { + registers :: Bimap ID Register, + frame :: Frame } + deriving Show data Future = Future { - fregisters :: Map ID Register + fregisters :: Bimap ID Register } + deriving Show data Info = Info { - idValue :: ID -> IO Int, + envInfo :: (ID,ID -> IO Int), bindings :: Map ID (ID,Int), + sizes :: Map ID Int, actives :: Set ID, clobbers :: Relation ID ID, - branchPos :: Int -> (Int,Int,Maybe Past) + locals :: Set ID, + branchPos :: (Int,Int -> (Int,Int,Maybe MemState)) } -stackF = Field (stack,\s p -> p { stack = s }) -bindingsF = Field (bindings,\a p -> p { bindings = a }) +frameF = Field (frame,\f p -> p { frame = f }) +registersF = Field (registers,\r p -> p { registers = r }) -emptyFuture = Future Data.Map.empty +emptyFuture = Future Data.Bimap.empty diff --git a/src/Specialize/X86_64.hs b/src/Specialize/X86_64.hs --- a/src/Specialize/X86_64.hs +++ b/src/Specialize/X86_64.hs @@ -1,96 +1,411 @@ -{-# LANGUAGE RankNTypes, ViewPatterns #-} +{-# LANGUAGE ViewPatterns, TupleSections, ParallelListComp, ImplicitParams, NoMonomorphismRestriction, Rank2Types #-} module Specialize.X86_64(arch_x86_64) where -import Specialize.Types -import Control.Monad -import qualified Data.ByteString as B +import Control.Monad.Writer.Class + +import Control.Arrow +import Control.Monad.Reader +import Control.Monad.Trans import Data.Bits -import My.Data.List import Data.Char +import Data.Function import Data.Maybe +import Data.Monoid import Data.Ord - +import My.Control.Monad +import My.Control.Monad.State +import My.Data.Either +import My.Data.List import My.Prelude +import Specialize.Types hiding (call) +import qualified Data.ByteString as B +import qualified Data.Map as M +import qualified Data.Bimap as BM +import qualified Data.Set as S +import qualified My.Data.SetBy as SB -defSize = 8 +fi :: (Integral a,Num b) => a -> b +fis :: (Integral a,Num b) => [a] -> [b] +bytes :: (Bits a,Integral a,Num b) => a -> [b] +defSize :: Num a => a +argBytesWide :: Bool -> Int -> Int -> (Maybe Integer) -> ([Word8],[Word8]) +codeFun :: [(Int,(Word8,Int))] -> (Int,IO Integer) -> Maybe (Word8,Int,Int,IO [Word8]) + +type OpT = MonadWriter BinCode m => (Int -> Int -> Int -> m () + ,Int -> Int -> (Int,IO Integer) -> m () + ,Int -> (Int,IO Integer) -> Int -> m () + ,Integer -> Integer -> Integer) + arch_x86_64 = Arch "x86_64" defSize defaults compile -fromFields fs = foldl1 xor (zipWith shiftL (map (fromIntegral . fst) fs) (scanl (+) 0 $ map snd fs)) +defSize = 8 +([rax,rcx,rdx,rbx,rsp,rbp,rsi,rdi,r8,r9,r10,r11,r12,r13,r14,r15],allocRegs) = + (regs,filter (not . (`elem`[rsp,r15])) regs) + where regs = [0..15] :: [Int] +fis = fmap fromIntegral ; fi = fromIntegral +k = Kleisli + showHex n = reverse $ map (intToDigit . fromIntegral . (`mod`16)) $ take 2 $ iterate (`div`16) (n :: Word8) showCode = intercalate " " . map showHex -argBytes :: Int -> Int -> (Maybe Integer) -> ([Word8],[Word8]) +bSize (bindSize -> (n,nr)) = n+nr*defSize +numSize n = length $ takeWhile (>0) $ iterate (`shiftR`8) n +withSize n = (numSize n,return $ fi n) +fromFields fs = foldl1 xor (zipWith shiftL (map (fst) fs) (scanl (+) 0 $ map snd fs)) +bytes = fis . iterate (`shiftR`8) +frameToStack n = (-8)-fi n + +fromBytesN n ml = BC (n,n,liftM B.pack ml) +fromBytes c = fromBytesN (length c) (return c) +tellCode c = tell $ fromBytes c + argBytes = argBytesWide True -argBytesWide w r rm arg = (pre,suf) +argBytesWide w r rm arg = (fis pre,fis suf) where pre = if rex/=0x40 then [rex] else [] where rex = fromFields [(rm`shiftR`3,1),(0,1),(r`shiftR`3,1),(fromEnum w,1),(4,4)] - suf = [fromFields [(rm.&.7,3),(r.&.7,3),(mode,2)]] ++ sib ++ index + suf = [fromFields [(rm.&.7,3),(r.&.7,3),(mode,2)]] ++ sib ++ fis index (mode,index) = maybe (3,[]) fun arg where fun n | n == 0 = if rm.&.7==5 then (1,[0]) else (0,[]) - | n <= 128 && n > -128 = (1,[fromIntegral n]) - | otherwise = (2,take 4 $ map (fromIntegral . (.&.255)) $ iterate (`shiftR`8) n) + | n <= 128 && n > -128 = (1,[n]) + | otherwise = (2,take 4 $ bytes n) sib | mode/=3 && (rm.&.7 == 4) = [fromFields [(4,3),(4,3),(0,2)]] | otherwise = [] -[rax,rbx,rsp,rbp,r8,r12] = [0,3,4,5,8,12] :: [Int] - op code d a b | d==b = op d a - | otherwise = mov d a++op d b - where op d a = pre++code++suf + | otherwise = mov d a >> op d b + where op d a = tellCode $ pre++code++suf where (pre,suf) = argBytes d a Nothing -opi codes d a n = mov d a ++ pre++[code]++suf++imm - where (code,r,imm) = codes (n :: Integer) - (pre,suf) = argBytes r d Nothing -codeFun codes n = head [(code,r,take s chop) | (s,(code,r)) <- codes, s>=size] - where size = length $ takeWhile (>0) divs - chop = map (.&.255) divs - divs = map fromIntegral $ iterate (`shiftR`8) n - -mov d s | d==s = [] - | otherwise = pre++[0x8B]++suf +opi codes def d a n = case codes n of + Just (code,r,s',imm) -> mov d a >> tell (fromBytesN (length pref+s') (liftM (pref++) imm)) + where (pre,suf) = argBytes r d Nothing + pref = pre++[code]++suf + Nothing -> movi r15 n >> op def d a r15 +codeFun codes (size,n) = listToMaybe [(code,r,s,imm s) | (s,(code,r)) <- codes, s>=size] + where imm s = liftM (take s . bytes) n + +mov d s | d==s = return () + | otherwise = tellCode $ pre++[0x8b]++suf where (pre,suf) = argBytes d s Nothing -movi d 0 = op [0x33] d d d -movi d n = pre++[code]++suf++imm - where (code,r,imm) = codeFun [(4,(0xC7,0)),(8,(0xB8`xor`(fromIntegral d.&.7),0))] n +movi d (0,_) = bwxor d d d +movi d n = tell $ fromBytesN (length pref+s) (liftM (pref++) imm) + where (code,r,s,imm) = fromJust $ codeFun [(4,(0xC7,0)),(8,(0xB8`xor`(fi d.&.7),0))] n (pre,suf) | code==0xC7 = argBytes 0 d Nothing | otherwise = (fst $ argBytes d 0 Nothing,[]) + pref = pre++[code]++suf +lea d s n = tellCode $ pre++[0x8d]++post + where (pre,post) = argBytes d s (Just n) + +shli = opi (codeFun [(1,(0xC1,4))]) undefined +shri = opi (codeFun [(1,(0xC1,5))]) undefined +rori d s n | n==0||n==64 = return () + | otherwise = opi (codeFun [(1,(0xC1,1))]) undefined d s (withSize n) +ld d (_,_,0) = return () ld d (s,n,size) = load where szs = maximumBy (comparing weight) $ permutations [sz | sz <- [8,4,2,1], sz.&.size /= 0] where weight l = sum $ zipWith f l $ sums l where f s i = fromJust $ findIndex (\p -> m.&.p==0) $ iterate (`shiftR`1) s where m = s-((n+i)`mod`s) - load = concat $ zipWith ld (reverse $ zip (sums szs) szs) (True:repeat False) - ld (i,sz) fst = sh sz++code++suf + load = sequence_ $ zipWith ldChunk (reverse $ zip (sums szs) szs) (True:repeat False) + ldChunk (i,sz) fst = do + sh sz + if sz==1 && d>=4 && d<8 + then (if fst then return () else mov r15 d) >> ld r15 (s,n+i,1) >> mov d r15 + else tellCode $ pre++code++suf where (pre,suf) = argBytesWide (sz==8) d s (Just (n+i)) - code = pre++fromJust (lookup sz [(8,[0x8b]),(4,[0x8b]),(2,[0x66,0x8b]),(1,[0x8a])]) - sh sz | fst||sz==8 = [] - | otherwise = shli d d (sz*8) - + code = fromJust (lookup sz [(8,[0x8b]),(4,[0x8b]),(2,[0x66,0x8b]),(1,[0x8a])]) + sh sz | fst||sz==8 = return () + | otherwise = shli d d (withSize (sz*8)) +st (_,_,0) _ = return () st (d,n,size) s = store where szs = maximumBy (comparing weight) $ permutations [sz | sz <- [8,4,2,1], sz.&.size /= 0] where weight l = sum $ zipWith f l $ sums l where f s i = fromJust $ findIndex (\p -> m.&.p==0) $ iterate (`shiftR`1) s where m = s-((n+i)`mod`s) - store = concat $ reverse $ zipWith st (reverse $ zip (sums szs) szs) (True:repeat False) - st (i,sz) lst = code++suf++sh sz + store = sequence_ $ reverse [stChunk a b | (a,b) <- zip (reverse $ zip (sums szs) szs) (True:repeat False)] + stChunk (i,sz) lst = do + (if sz==1 && d>=4 && d<8 + then mov r15 s >> st (d,n+i,1) r15 + else tellCode $ pre++code++suf) + sh sz where (pre,suf) = argBytesWide (sz==8) s d (Just (n+i)) - code = pre++fromJust (lookup sz [(8,[0x89]),(4,[0x89]),(2,[0x66,0x89]),(1,[0x88])]) + code = fromJust (lookup sz [(8,[0x89]),(4,[0x89]),(2,[0x66,0x89]),(1,[0x88])]) sh sz | lst = rori s s ((8-i)*8) | otherwise = rori s s (sz*8) -add = op [0x03] -sub = op [0x2B] -mul = op [0x0F,0xAF] -addi = opi $ codeFun [(1,(0x83,0)),(4,(0x81,0))] -subi = opi $ codeFun [(1,(0x83,5)),(4,(0x81,5))] -muli = opi $ codeFun [(1,(0x6B,0)),(8,(0x69,0))] -shli = opi $ codeFun [(1,(0xC1,4))] -shri = opi $ codeFun [(1,(0xC1,5))] -rori d s n | n==0||n==64 = [] - | otherwise = opi (codeFun [(1,(0xC1,1))]) d s n +commOp c c' f = (op c,opn,flip . opn,f :: Integer -> Integer -> Integer) + where opn = opi (codeFun c') c -(e,s,c) <++> (e',s',c') = (e+e',s+s',liftM2 B.append c c') +adds@(add,addi,_,_) = commOp [0x03] [(1,(0x83,0)),(4,(0x81,0))] (+) +muls@(mul,muli,_,_) = commOp [0x0F,0xAF] [(1,(0x6B,0)),(8,(0x69,0))] (*) +bwands@(bwand,bwandi,_,_) = commOp [0x23] [(1,(0x83,4)),(4,(0x81,4))] (.&.) +bwors@(bwor,bwori,_,_) = commOp [0x0b] [(1,(0x83,1)),(4,(0x81,1))] (.|.) +bwxors@(bwxor,bwxori,_,_) = commOp [0x33] [(1,(0x83,6)),(4,(0x81,6))] xor +subs :: OpT +subs@(sub,subi,_,_) = (sub,opi (codeFun codes) [0x2b],subi',(-)) + where neg r = tellCode $ pre++[0xf7]++post + where (pre,post) = argBytes 3 r Nothing + sub d a b | d==b = op [0x2b] d d a >> neg d + | otherwise = op [0x2b] d a b + codes = [(1,(0x83,5)),(4,(0x81,5))] + subi' d n a | d==a = subi d d n >> neg d + | otherwise = movi d n >> sub d d a +cmps f = (cmp,cmpi,cmp',f) + where cmp _ a b = op [0x3b] a a b + codes = [(1,(0x83,7)),(4,(0x81,7))] + cmpi _ a = opi (codeFun codes) [0x3b] a a + cmp' _ n a = movi r15 n >> cmp r15 r15 a -defaults args ret = undefined -compile = undefined +calli pos (_,v) = tell $ fromBytesN 5 (liftM2 (\p v -> [0xe8]++take 4 (bytes (v-fi p-5))) pos v) +call r = tellCode $ pre++[0xff]++post + where (pre,post) = argBytes 2 r Nothing + +opsCode (rr,ri,ir,ii) dest v v' = case (v,v') of + (Left r,Left r') -> rr dest r r' + (Left r,Right v) -> ri dest r v + (Right v,Left r) -> ir dest v r + (Right (s,n),Right (s',n')) -> movi dest (max s s',liftM2 ii n n') + +associate d r = modifyF registersF $ BM.insert d r +frameAddr s = stateF frameF (withAddr defSize s) +lookupSymIn = flip BM.lookupR +lookupRegIn = flip BM.lookup +lookupArgReg (SymVal Value s) m = BM.lookup s m +lookupArgReg _ _ = Nothing + +miscInfos = ask >>= \info -> do + let argVal (IntVal n) = Right $ withSize n + argVal (SymVal Size s) = Right $ withSize $ fromMaybe defSize $ M.lookup s (sizes info) + argVal (SymVal SymID (ID s)) = Right $ withSize $ s + argVal (SymVal _ s) = maybe (Left s) (Right . (4,)) $ globVal s + globVal s = if isLocal s then Nothing else Just (fi $< snd (envInfo info) s) + isLocal s = S.member s (locals info) + binding s = M.lookup s (bindings info) + return (argVal,globVal,isLocal,binding) + +withFreeSet m = liftM3 (,,) ask get (future get) >>= \(i,p,f) -> do + let cmp r r' = case (regVar r,regVar r') of + (Just _,Nothing) -> GT + (Nothing,Just _) -> LT + (Nothing,Nothing) -> case (fRegVar r,fRegVar r') of + (Just _,Nothing) -> GT + (Nothing,Just _) -> LT + _ -> compare r r' + (Just v,Just v') -> (isActive v`compare`isActive v')`mappend`compare r r' + regVar = lookupSymIn $ registers p + fRegVar = lookupSymIn $ fregisters f + isActive v = S.member v $ actives i + evalStateT m (SB.fromList cmp allocRegs) + +protectFuture m = StateT s + where s t = RWTL (\r p f -> let ~(p',_,a,w) = runRWTL (runStateT m t) (r,f) p undef in (p',f,a,w)) + undef = error "Illegal use of protected future" +unProtectFuture m = StateT s + where s t = RWTL (\(r,f) p _ -> runRWTL (runStateT m t) r p f) +preserve m = StateT s + where s t = RWTL (\r p f -> let (_,f',a,w) = runRWTL (runStateT m t) r p f in (p,f',a,w) ) + +infos = liftM3 (,,) (asks fst) get (asks snd) +varSize s = fromMaybe defSize $< asks (M.lookup s . sizes . fst) +argSize (SymVal Value s) = varSize s +argSize _ = return defSize + +allocReg sym = asks (fregisters . snd) >>= \regs -> do + let st free = (r,SB.delete r free) + where r | SB.null free = r15 + | otherwise = fromMaybe (SB.findMin free) $ mfilter (`SB.member`free) $ lookupRegIn regs sym + r <- state st + return r + +destRegister d = lift infos >>= \(i,p,f) -> + case mfilter (\r -> maybe True (==d) $ BM.lookupR r (registers p)) $ lookupRegIn (fregisters f) d of + Just r -> return r + Nothing -> case find ((==Just d) . findReg) allocRegs `mplus` find (isNothing . findReg) allocRegs of + Just r -> return r + Nothing -> storeRegs [head allocRegs] >> return (head allocRegs) + where findReg s = lookupSymIn (registers p) s `mplus` lookupSymIn (fregisters f) s + +loadRoot (Just s) = lift get >>= \p -> case lookupRegIn (registers p) s of + Just r -> return r + Nothing -> do + r <- allocReg s + a <- lift (frameAddr s) + lift $ associate s r + ld r (rsp,fi a,defSize) + return r +loadRoot Nothing = return rsp + +storeRegs regs = lift get >>= \p -> do + (_,_,_,binding) <- unProtectFuture miscInfos + let vars = [(r,s,binding s) | (r,Just s) <- zip regs (map (lookupSymIn (registers p)) regs)] + parent (_,_,b) = fmap fst b + groups = classesBy ((==)`on`parent) vars + storeGroup g = do + reg <- loadRoot $ parent $ head g + mapM_ (store reg) g + where store base (r,s,b) = do + n <- maybe (lift $ frameAddr s) (return . snd) b + sz <- varSize s + st (base,frameToStack n,fi sz) r + restrict m = gets (SB.partition isFree) >>= \(free',occ) -> put free' >> m >> modify (SB.union occ) + where isFree = isNothing . lookupSymIn (registers p) + restrict $ mapM_ storeGroup groups + lift $ modifyF registersF $ \rs -> foldr BM.delete rs [s | (_,s,_) <- vars] + +loadArgs args = do + lift $ future $ modify $ \f -> f { fregisters = foldr (uncurry BM.insert) (fregisters f) + [(s,r) | (SymVal Value s,Just r) <- args] } + protectFuture $ do + (argVal,globVal,isLocal,binding) <- unProtectFuture miscInfos + p <- lift get + let fixed = mapMaybe snd args + argAlloc (arg,Nothing) = runKleisli (left $ k f) (argVal arg) + where f s = get >§ \free -> maybe (Left s) Right $ mfilter (`SB.member` free) (BM.lookup s (registers p)) + argAlloc (_,Just r) = return (Left $ Right r) + argNew = runKleisli (left $ k allocReg ||| k return) + modify $ \s -> foldr SB.delete s fixed + alls <- mapM argAlloc args + modify $ \s -> foldr SB.delete s [r | Left (Right r) <- alls] + allocs <- mapM argNew alls + let assocs = filter (\(r,arg,_) -> not $ (myWorkIsDone r ||| const False) (argVal arg)) + $ lefts [left (,arg,bind arg) all | all <- allocs | (arg,_) <- args] + bind (SymVal _ s) | isLocal s = binding s + bind _ = Nothing + groups = classesBy ((==)`on`parent) assocs + parent (_,_,b) = fmap fst b + myWorkIsDone r s = lookupRegIn (registers p) s == Just r + loadGroup g = do + base <- loadRoot $ parent $ head g + mapM_ (load base) g + where load base (r,arg,b) = case argVal arg of + Right v -> movi r v + Left s -> do + n <- maybe (lift $ frameAddr s) return $ fmap snd b + sz <- varSize s + let SymVal t _ = arg + if t==Value then ld r (base,frameToStack n,fi sz) else lea r base (fi n) + + storeRegs [r | (r,_,_) <- assocs] + mapM_ loadGroup groups + lift $ modifyF registersF $ \m -> foldr (uncurry BM.insert) m [(s,r) | ((SymVal _ s,_),Left r) <- zip args allocs] + return allocs + +defaults args ret = (MemState pregs frame,Future fr) + where (regArgs,stArgs) = partition ((<=defSize) . bSize) args + (regs,nonRegs) = zipRest argRegs regArgs + (retReg:funReg:argRegs) = allocRegs + pregs = BM.fromList [(bindSym v,r) | (r,v) <- regs] + frame = foldr (frameAlloc defSize) emptyFrame (stArgs++nonRegs) + fr | bSize ret<=defSize = BM.singleton (bindSym ret) retReg + | otherwise = BM.empty + +compile (Op BCall d (fun:args)) = withFreeSet $ do + (instr,brInfo) <- asks branchPos + (myID,addrs) <- asks envInfo + sizes <- protectFuture $ mapM argSize args + let (MemState regs subFrame,_) = defaults [BindVar id (sz,0) 0 [] | (id,arg) <- argAssocs | sz <- sizes] undefined + argAssocs = zip (map ID [0..]) args + start = BC (est,pos,undefined) where (est,pos,_) = brInfo instr + (argVal,_,_,binding) <- miscInfos + modify (SB.delete rax) + (func:_,cload) <- listen $ loadArgs $ (fun,Nothing):[(arg,r) | (id,arg) <- argAssocs, let r = BM.lookup id regs, isJust r] + protectFuture $ do + (_,cstore) <- listen $ get >>= \free -> storeRegs (rax:SB.toList free) + + top <- lift $ gets (frameTop . frame) + let storeBig (id,arg) = case lookupAddr id subFrame of + Just addr -> case argVal arg of + Left s -> do + let loadAddr (r,n) = do a <- frameAddr r ; ld r15 (rsp,fi a,defSize) ; return (r15,a) + (base,n) <- maybe ((rsp,) $< frameAddr s) loadAddr $ binding s + sz <- argSize arg + let addrs = [0,defSize..sz] + sequence_ [ld rax (base,fi$n+a,fi sz) >> st (rsp,fi $ top+defSize+addr+a,fi sz) rax + | a <- addrs, let sz = min defSize (sz-a)] + Right v -> movi r15 v >> st (rsp,fi $ top+defSize+addr,defSize) rax + Nothing -> return () + (_,cstore') <- listen $ do + lift $ mapM_ storeBig argAssocs + subi rsp rsp $ withSize top + let pos = thisFunc >§ \p -> p+instrPos+delta + BC ~(_,delta,_) = cload <> cstore <> cstore' + (_,instrPos,_) = brInfo instr ; thisFunc = addrs myID + runKleisli (k call ||| k (calli pos)) func + addi rsp rsp $ withSize top + +compile (Op BSet d [s]) = withFreeSet $ do + [v] <- loadArgs [(s,Nothing)] + protectFuture $ do + dest <- destRegister d + runKleisli (k (mov dest) ||| k (movi dest)) v + lift $ associate d dest +compile (Op b d [a,a']) | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do + let ops = fromJust $ lookup b [(BAdd,adds),(BSub,subs),(BMul,muls),(BAnd,bwands),(BOr,bwors),(BXor,bwxors)] + [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)] + protectFuture $ do + dest <- destRegister d + opsCode ops dest v v' + lift $ associate d dest + | b`elem`[BLowerThan,BLowerEq,BEqual,BNotEqual,BGreaterEq,BGreaterThan] = withFreeSet $ do + let dest = 16 + fromJust (lookup b codes) + codes = [(BLowerThan,0xf),(BLowerEq,0xd),(BGreaterEq,0xc),(BGreaterThan,0xe),(BEqual,0x5),(BNotEqual,0x4)] + applys = [(BLowerThan,(<)),(BLowerEq,(<=)),(BGreaterEq,(>=)),(BGreaterThan,(>)),(BEqual,(==)),(BNotEqual,(/=))] + convert f n n' = if f n n' then 1 else 0 + [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)] + protectFuture $ do + opsCode (cmps $ convert $ fromJust (lookup b applys)) dest v v' + lift $ associate d dest + | b`elem`[BMod,BDiv] = withFreeSet $ do + protectFuture $ storeRegs [rdx] + movi rdx $ withSize (0 :: Int) + [_,v] <- loadArgs [(a,Just rax),(a',Nothing)] + protectFuture $ case v of + Left r -> op [0xf7] 7 7 r + Right v -> opi (codeFun []) [0xf7] 7 7 v + lift $ associate d (case b of BMod -> rdx ; BDiv -> rax) + +compile (Op b d args@(a:a':t)) | isBinOp b = mapM_ compile $ Op b d [a,a']:[Op b d [SymVal Value d,a''] | a'' <- t] + | otherwise = undefined +compile i@(Op _ _ _) = return () +compile (Branch v alts) = withFreeSet $ do + (instr,brInfo) <- asks branchPos + let alignPast instr = preserve $ case brInfo instr of + (_,_,Just (registers -> regs)) -> protectFuture $ listening $ do + unProtectFuture $ loadArgs [(SymVal Value s,Just r) | (s,r) <- BM.toList regs] + free <- get + storeRegs (SB.toList free) + _ -> return mempty + jmpc short long (BC (e,a,_)) (BC (e',a',_)) = BC (length long+4,length code,return $ B.pack code) + where de = e'-e ; da = a'-a + code | de==0 = [] + | de > -128 && de<=128 = short++take 1 (bytes da) + | otherwise = long++take 4 (bytes da) + jmp = jmpc [0xeb] [0xe9] + start i = BC (est,pos,undefined) where (est,pos,_) = brInfo i + + case alts of + [def,null] -> do + (r,c) <- listen $ protectFuture $ do + r <- lift $ gets (lookupArgReg v . registers) + case mfilter (>=16) r of + Just r -> return r + Nothing -> unProtectFuture (loadArgs [(v,Nothing)]) >§ \[Left r] -> r + [al,al'] <- mapM alignPast [def,null] + let [_,_,p1,_,p2,_,p3] = scanl mappend (start instr) codes + (d1,jmp2) = if isEmptyCode al' then (start null,mempty) else (p2,jmp p3 (start null)) + codes = [c,jmpc cshort clong p1 d1,al,jmp p2 (start def),al',jmp2] + cshort = [0x70+testCode] ; clong = [0x0f,0x80+testCode] ; testCode = fi $ r-16 + mapM_ tell codes + [def] -> do + al <- alignPast def + let [_,_,p] = scanl mappend (start instr) codes + codes = [al,jmp p (start def)] + mapM_ tell codes + [] -> tellCode [0xc3] + +compile (Bind bv Nothing) = modifyF frameF (frameAlloc defSize bv) >> return () +compile (Bind bv _) = return () +compile Noop = return () + +ignore m = return () + diff --git a/src/Syntax.hs b/src/Syntax.hs --- a/src/Syntax.hs +++ b/src/Syntax.hs @@ -24,13 +24,3 @@ show (Symbol s) = show s show (Group l) = "[" ++ intercalate " " (map show l) ++ "]" --- Copyright (c) 2012, Coiffier Marc --- 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. - diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -2,7 +2,7 @@ import Syntax import Text.ParserCombinators.Parsec hiding (spaces) -import My.Control.Monad +import My.Control.Monad import Data.Maybe parseAlpha file s = lazyMany axiom file s @@ -15,34 +15,34 @@ lm state = case parse p' "" "" of Left err -> error (show err) Right x -> x - where + where p' = do setParserState state - choice [ + choice [ try (oWhite >> eof >> return []), liftM2 (:) (p >>= \p -> optional (oneOf ",;") >> return p) $ lm $< getParserState] -wrParen e@(_:_:_) = mkNode e -wrParen e = concat e +wrParen e@(_:_:_) = mkNode e +wrParen e = concat e mkNode = return . Group . concat free :: Parser a -> Parser a free e = try $ between oWhite oWhite e -- Productions axiom = free boundExpr - -atom = (\x -> [x]) $< symbol <|> parGroup - + +atom = liftM return symbol <|> parGroup + wrap beg g end = between (string beg) (string end) g parGroup = wrap "(" (inParen wrParen) ")" <|> wrap "[" (inParen mkNode) "]" <|> wrap "{" (inParen concat) "}" -inParen wr = wr $< (oWhite >> looseExpr`endBy`oWhite) +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") $ chain (return ()) op =<< tightExpr @@ -50,29 +50,19 @@ 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")) - where string = do + where string = do sep <- (char '\'' >> anyChar) <|> char '"' str <- many (quoted $ satisfy (/=sep)) char sep return $ '\'':sep:str symbol = many1 $ quoted $ noneOf " \t\n()[]{},;.:_" - quoted p = (char '\\' >> esc $< anyChar) <|> p + quoted p = (char '\\' >> (esc $< anyChar)) <|> p esc c = fromMaybe c $ lookup c [('n','\n'),('t','\t')] - + white = skipMany1 ((comment <|> spaces) "whitespace") where spaces = skipMany1 $ space comment = (char '~' >> optional spaces >> void (many1 atom)) "comment" oWhite = optional $ white - --- Copyright (c) 2012, Coiffier Marc --- 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. diff --git a/src/Translate.hs b/src/Translate.hs --- a/src/Translate.hs +++ b/src/Translate.hs @@ -32,13 +32,3 @@ 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 --- 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. -