diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 0.9.8 +version: 0.9.9 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,8 @@ 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 + build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, relation 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.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, 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.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 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 @@ -74,19 +74,19 @@ createDirectoryIfMissing True (dropFileName langFile) B.writeFile langFile (Ser.encode lang) return lang - loadLanguage name = compileLanguage name >>= execCode . loadCode >> languageState get + loadLanguage name = compileLanguage name >>= execCode . initializeL >> languageState get compileFile src = withDefaultContext $ (>> gets language) $ do str <- readFile src let sTree = concat $ parseAlpha src str code <- mapM compileExpr sTree - languageState $ modify $ \e -> exportLanguage $ e { loadCode = foldr concatCode [] code } + languageState $ modify $ \e -> exportLanguage $ e { initializeL = foldr concatCode [] code } where compileExpr expr = print (fmap Str expr) >> do symExpr <- languageState $ envCast expr print symExpr trExpr <- doTransform symExpr (code,imports) <- languageState $ compile Nothing trExpr - mapM_ (importLanguage compileLanguage (execCode . loadCode)) imports + mapM_ (importLanguage compileLanguage (execCode . initializeL)) imports execCode code return code diff --git a/src/Compile.hs b/src/Compile.hs --- a/src/Compile.hs +++ b/src/Compile.hs @@ -1,21 +1,19 @@ {-# LANGUAGE TupleSections, ParallelListComp, NoMonomorphismRestriction #-} module Compile(compile) where -import Debug.Trace - -import My.Prelude +import Compile.State as CS +import Compile.Utils +import Context.Language +import Data.Either +import Data.Maybe +import ID +import My.Control.Monad +import My.Control.Monad.State 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 My.Prelude import PCode -import Context.Language import Syntax -import ID -import Compile.Utils -import Compile.State as CS compile dest expr = runStateT st defaultState >ยง \(code,cs) -> (code,imports cs) where st = do @@ -47,7 +45,9 @@ sequence_ [createEdge TimeDep n' n | (_,l) <- code, n' <- l] return (SymVal Value dest,(n:concatMap fst code,[n])) -compileBuiltin = compileBy . Op +compileBuiltin = compileBy . simplify + where simplify op dest [] = Op BSet dest [IntVal 0] + simplify op dest vars = Op op dest vars compileCall = compileBuiltin BCall compileAxiom XAlter _ forms = do @@ -55,15 +55,17 @@ 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 = doBind args +compileAxiom XBind _ args = case args of + [bVars] -> doBind bVars Nothing + [bVars,expr] -> do + v <- newVar + compile' (Just v) expr *>> doBind bVars (Just v) where - doBind' bVars compile = compile *>>= \v -> do + doBind bVars val = do bnd <- bindFromSyntax bVars - n <- createNode (Instr $ PCode.Bind bnd v) + n <- createNode (Instr $ PCode.Bind bnd val) return (NullVal,singleCode n) - doBind [bVars] = doBind' bVars $ nullCode - doBind [bVars,expr] = doBind' bVars $ newVar >>= \v -> compile' (Just v) expr - + compileAxiom XDo dest [] = nullCode compileAxiom XDo dest forms = do let cs = reverse $ zipWith compile' (dest:repeat Nothing) (reverse forms) diff --git a/src/Compile/State.hs b/src/Compile/State.hs --- a/src/Compile/State.hs +++ b/src/Compile/State.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction, ViewPatterns #-} module Compile.State( module Context, module My.Data.Graph, @@ -104,7 +104,7 @@ br <- createNode (BrPart val) let makeAlt n = createEdge (BranchAlt typ n) br case val of - IntVal i -> makeAlt 0 (if i+1 i) -> makeAlt 0 (if i+1 sequence_ $ zipWith makeAlt [0..] alts return (NullVal,([br],[])) diff --git a/src/Context/Language.hs b/src/Context/Language.hs --- a/src/Context/Language.hs +++ b/src/Context/Language.hs @@ -23,28 +23,28 @@ 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)]] + ["Max ID: "++show (maxIDL e)], + showTable "Symbols" (\(s,i) -> [s++" -> "++show i]) $ BM.toList (symbolsL e), + showTable "Aliases" (\(i,i') -> [show i++" -> "++show i']) $ M.toList (aliasesL e), + showTable "Equivs" (\(i,i') -> [show i++" -> "++show i']) $ M.toList (equivsL e), + showTable "Modules" (\(s,Range r) -> [s++" -> "++show r]) $ BM.toList (languagesL e), + showTable "Values" (\(i,v) -> [show i++" -> "++show v]) $ M.toList (valuesL e), + ["Exports: "++show (exportsL e)], + ["Load code: "++show (initializeL e)]] -empty = Language (toEnum 0) BM.empty M.empty M.empty BM.empty M.empty S.empty undefined +empty = Language (toEnum 0) BM.empty M.empty M.empty BM.empty M.empty S.empty [] -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) +createSym e@(Language { maxIDL = m }) = (m,e { maxIDL = succ m }) +setSymVal id v e = e { valuesL = M.insert id v (valuesL e) } +lookupSymName id e = BM.lookupR id (symbolsL e) +lookupSymVal id e = fromMaybe NoValue $ M.lookup id (valuesL e) +lookupSymMod id e = BM.lookupR (singleRange id) (languagesL e) +addExport id e = e { exportsL = S.insert id (exportsL e) } +getImports e = map fst $ BM.toList $ languagesL e +isImport im e = BM.member im (languagesL e) exportSymVal id v = setSymVal id v . addExport id -internSym s e = runState (st $ BM.lookup s (symMap e)) e +internSym s e = runState (st $ BM.lookup s (symbolsL e)) e where st (Just id) = return id st _ = do i <- state createSym @@ -59,45 +59,45 @@ where merge imp = gets language >>= \l -> unless (imp`isImport`l) $ do l' <- getImport imp - mapM_ merge [imp | (imp,_) <- BM.toList (modMap l')] + mapM_ merge [imp | (imp,_) <- BM.toList (languagesL l')] mergeLanguage l' loadImport l' mergeLanguage l' = doF languageF $ do - let Language { symMap = syms' , modMap = mods' , maxID = mi' } = l' + let Language { symbolsL = syms' , languagesL = mods' , maxIDL = mi' } = l' mapM_ (state . internSym) $ BM.keys syms' - Language { maxID = mi, symMap = syms } <- get + Language { maxIDL = mi, symbolsL = 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) + maxIDL = mi+mi', + aliasesL = aliasesL l `M.union` M.fromList aliases, + equivsL = equivsL l `M.union` M.fromList (map swap aliases) } - Language { aliasMap = al , modMap = mods } <- get + Language { aliasesL = al , languagesL = 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' + Range (r,_) <- BM.lookup m mods + Range (r',_) <- BM.lookup m mods' return $ s'-r'+r - newVals = M.mapKeys tr $ M.map (translate tr) $ valMap l' + newVals = M.mapKeys tr $ M.map (translate tr) $ valuesL 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) + languagesL = BM.insert imp (Range (mi,mi+mi')) (languagesL l), + valuesL = M.unionWith (\_ a -> a) (valuesL l) newVals, + exportsL = S.difference (exportsL 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) + symbolsL = BM.filter exportNameP (symbolsL e), + valuesL = vals', + aliasesL = M.empty, + equivsL = M.empty, + exportsL = S.empty, + initializeL = translate trans (initializeL e) } where set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined)) - Language { exports = ex, equivMap = eqs } = e - vals' = M.map (translate trans) $ M.intersection (valMap e) (set2Map ex) + Language { exportsL = ex, equivsL = eqs } = e + vals' = M.map (translate trans) $ M.intersection (valuesL 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) diff --git a/src/Context/Types.hs b/src/Context/Types.hs --- a/src/Context/Types.hs +++ b/src/Context/Types.hs @@ -24,17 +24,17 @@ 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] + maxIDL :: ID, + symbolsL :: Bimap String ID, + aliasesL :: Map ID ID, + equivsL :: Map ID ID, + languagesL :: Bimap String (Range ID), + valuesL :: Map ID Context.Types.Value, + exportsL :: Set ID, + initializeL :: [Instruction] } -symsF = Field (symMap,\s ce -> ce { symMap = s }) -valsF = Field (valMap,\v ce -> ce { valMap = v }) +symsF = Field (symbolsL,\s ce -> ce { symbolsL = s }) +valsF = Field (valuesL,\v ce -> ce { valuesL = v }) data Context = C { language :: Language, diff --git a/src/ID.hs b/src/ID.hs --- a/src/ID.hs +++ b/src/ID.hs @@ -2,15 +2,14 @@ newtype ID = ID Int deriving (Ord,Eq) -newtype IDRange = IDRange (ID,ID) - deriving Show - -singleRange i = IDRange (i,i) +newtype Range a = Range (a,a) -instance Eq IDRange where +singleRange i = Range (i,i) + +instance Ord a => Eq (Range a) where a == b = compare a b == EQ -instance Ord IDRange where - compare (IDRange (a,b)) (IDRange (a',b')) = +instance Ord a => Ord (Range a) where + compare (Range (a,b)) (Range (a',b')) = if b<=a' then LT else if b'<=a then GT else EQ @@ -28,7 +27,6 @@ abs = undefined signum = undefined fromInteger n = ID $ fromInteger n - -- Copyright (c) 2012, Coiffier Marc -- All rights reserved. diff --git a/src/My/Control/Monad/TimeLine.hs b/src/My/Control/Monad/TimeLine.hs --- a/src/My/Control/Monad/TimeLine.hs +++ b/src/My/Control/Monad/TimeLine.hs @@ -25,7 +25,6 @@ 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 diff --git a/src/My/Data/Either.hs b/src/My/Data/Either.hs new file mode 100644 --- /dev/null +++ b/src/My/Data/Either.hs @@ -0,0 +1,7 @@ +module My.Data.Either (module Data.Either, fromLeft, fromRight, fromEither) 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 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) where +module My.Data.List(module Data.List,classesBy,nubOrd,sums) where import Data.List @@ -8,6 +8,9 @@ classesBy :: (a -> a -> Bool) -> [a] -> [[a]] classesBy (==) [] = [] 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. 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,6 +1,7 @@ module My.Data.Tree(module Data.Tree ,nubT,iterateT - ,spanningTree) where + ,spanningTree + ,branches, nodeList) where import Data.Tree import Data.Set as S @@ -12,4 +13,12 @@ return (a,[sub | sub <- subs, not (S.member (rootLabel sub) s)]) iterateT seed f = unfoldTree (\a -> (a,f a)) seed +branches (Node a []) = [[a]] +branches (Node a (sub:subs)) = let (b:t) = branches sub in ((a:b):t++concatMap branches subs) + spanningTree seed nexts = nubT $ iterateT seed nexts + +nodeList n@(Node _ subs) = n:concatMap nodeList subs + +test = Node 1 [Node 2 [Node 3 [],Node 4 []], + Node 5 [Node 6 [],Node 7 []]] diff --git a/src/PCode/Instruction.hs b/src/PCode/Instruction.hs --- a/src/PCode/Instruction.hs +++ b/src/PCode/Instruction.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns, ParallelListComp #-} module PCode.Instruction where import Control.Monad.State @@ -20,7 +20,7 @@ } data Instruction = Op Builtin ID [Value] | Branch Value [Addr] - | Bind BindVar Value + | Bind BindVar (Maybe ID) | Noop data Code = Code [BindVar] [Instruction] BindVar deriving Show @@ -31,18 +31,28 @@ isBranch _ = False bindSyms bv = bindSym bv : concatMap bindSyms (map fst $ bindSubs bv) +bindNodes bv = bv:map fst (bindSubs bv) symBind s = BindVar s (0,1) 0 [] instrVals (Op _ _ vs) = vs -instrVals (Bind _ v) = [v] +instrVals (Bind _ v) = map (SymVal Value) $ maybeToList v instrVals (Branch v _) = [v] instrVals _ = [] instrVars (Op _ v _) = [v] instrVars (Bind v _) = bindSyms v instrVars _ = [] +flattenBind def = flatten + where sizeOf (bindSize -> (s,sr)) = s+sr*def + flatten bv@(BindVar s _ p subs) = (s,0,sizeOf bv):concat [ + [(s,n+n0,sz) | (s,n,sz) <- flatten bv] + | (bv,_) <- subs + | n0 <- scanl (+) p [n*sizeOf bv | (bv,n) <- subs]] + set v val = Op BSet v [val] call v f args = Op BCall v (f:args) ret = Branch NullVal [] +isRet (Branch NullVal []) = True +isRet _ = False concatCode c1 [] = c1 concatCode c1 c2 = map (f g1) c1 ++ map (f g2) c2 diff --git a/src/PCode/Value.hs b/src/PCode/Value.hs --- a/src/PCode/Value.hs +++ b/src/PCode/Value.hs @@ -11,7 +11,7 @@ data ValType = Value | Address | Size | SymID deriving Eq data Value = SymVal ValType ID - | IntVal Int + | IntVal Integer | NullVal varEqVal n (SymVal Value n') = n==n' @@ -19,14 +19,14 @@ 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 + where + parseInt r s + | all isHexDigit s = + case find (>=r) digs of + Just d -> Left $ "digit '"++[intToDigit $ fromIntegral 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 (fromIntegral . digitToInt) s instance Show Value where show (SymVal t v) = prefix++show v diff --git a/src/Serialize.hs b/src/Serialize.hs --- a/src/Serialize.hs +++ b/src/Serialize.hs @@ -20,7 +20,7 @@ deriving instance Generic C.Value deriving instance Generic Axiom deriving instance Generic ID -deriving instance Generic IDRange +deriving instance Generic (Range a) deriving instance Generic Language instance Serialize ValType @@ -32,7 +32,7 @@ instance Serialize C.Value instance Serialize Axiom instance Serialize ID -instance Serialize IDRange +instance Serialize a => Serialize (Range a) instance (Ord a,Ord b,Serialize a,Serialize b) => Serialize (Bimap a b) where get = BM.fromList $< get put = put . BM.toList diff --git a/src/Specialize.hs b/src/Specialize.hs --- a/src/Specialize.hs +++ b/src/Specialize.hs @@ -1,17 +1,121 @@ +{-# LANGUAGE RankNTypes, ParallelListComp, TupleSections #-} module Specialize(specialize) where -import PCode +import Data.Monoid +import Control.Arrow import Context.Types +import Control.Monad.Trans.Reader +import Data.Array +import Data.List +import Data.Maybe import Data.Word -import Specialize.Architecture +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 ID -import Data.ByteString +import My.Control.Monad +import My.Control.Monad.State +import My.Control.Monad.TimeLine +import My.Data.Either +import My.Data.Tree +import PCode +import Specialize.Architecture +import Specialize.Architecture +import Specialize.Types +import System.IO.Unsafe +import My.Prelude + retCode = ret where ret = [0xc3] exit = [0x31,0xdb ,0x31,0xc0, 0xff,0xc0 - ,0xcd,0x80] + ,0xcd,0x80] +sums = scanl (+) 0 -specialize :: Monad m => Architecture -> (ID -> m Int) -> Code -> (Int,m ByteString) -specialize arch assoc (Code args code ret) = (Prelude.length retCode,return $ pack retCode) +specialize arch assoc (Code args code retVar) = foo + where + foo = (sum sizes,B.concat $< sequence codes) + -- foo = (length retCode, return (B.pack retCode)) + (estimates,sizes,codes) = unzip3 [v | Right (_,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] + codeTree = spanningTree 0 nexts + runInstr i (p,f) past = runTimeLine (runReaderT (compile $ instr i) ((infos!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 + + 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] + + instructions = execState (specializeTree past codeTree) initialArray + 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) + 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] + next _ bnd _ = bnd + activesA = saturate fun prevs nexts init start + where init = accumArray const S.empty bounds [] + 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) + <> S.unions [clobbers i s' | SymVal Value s <- vs + , s' <- s:maybeToList (parent i s)] + <> maybe S.empty (clobbers i) (parent i v) + 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 _ 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 + , 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') + , ass <- [(s,ref),(ref,s)]] + next _ r _ = r + lookupRefs v r = fromMaybe (S.singleton (ID (-1))) $ R.lookupRan v r + references i v = lookupRefs v (referencesA!i) + referencesA = treeArray next R.empty + where next i r (Op _ v vs) = insertManyR r' (map (v,) $ S.toList refs) + 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) + +saturate fun nexts prevs init start = f init (array (bounds init) [(i,length $ prevs i) | i <- indices init]) start + where f a d [] = a + f a d (i:t) | newElt == a!i = f a d t + | otherwise = f (a//[(i,newElt)]) d'' (foldr (insertBy (comparing (d''!))) (filter (/=i) t) (nexts i)) + where newElt = fun i a + d' = d // [(i,length $ (prevs`asTypeOf`nexts) i)] + d'' = d' // [(n,(d'!n)-1) | n <- nexts i] diff --git a/src/Specialize/Architecture.hs b/src/Specialize/Architecture.hs --- a/src/Specialize/Architecture.hs +++ b/src/Specialize/Architecture.hs @@ -1,21 +1,18 @@ module Specialize.Architecture(Architecture(..),arch_x86,arch_x86_64,arch_arm,hostArch,architectures) where import Specialize.Types -import PCode.Instruction -import My.Control.Monad.TimeLine -import Data.Ord -import Data.Word -import Data.Set as S +import Specialize.X86_64 instance Eq Architecture where a == a' = archName a == archName a' instance Show Architecture where show a = "#" +undef s = error $ "undefined ("++s++")" + architectures = [hostArch,arch_x86,arch_x86_64,arch_arm] -nullArch = Arch undefined undefined undefined undefined undefined +nullArch = Arch undefined undefined (undef "initials") (undef "compile") arch_x86 = nullArch { archName = "x86", archDefaultSize = 4 } -arch_x86_64 = nullArch { archName = "x86_64", archDefaultSize = 8 } arch_arm = nullArch { archName = "arm", archDefaultSize = 4 } hostArch = arch_x86_64 { archName = "host" } diff --git a/src/Specialize/Types.hs b/src/Specialize/Types.hs --- a/src/Specialize/Types.hs +++ b/src/Specialize/Types.hs @@ -2,36 +2,46 @@ module Specialize.Types( module Data.Word, module My.Control.Monad.TimeLine, module PCode, module ID, - Register(..),Address(..), + Register(..), Architecture(..), - Past(..),Future(..), - Allocate(..)) where + Info(..), Past(..),Future(..), + stackF,bindingsF, emptyFuture) where +import Data.Relation import Data.ByteString import Data.Word import My.Control.Monad.TimeLine +import My.Control.Monad.State +import Control.Monad.Trans.Reader import PCode import ID import Data.Map import Data.Set type Register = Int -type Address = (Maybe ID,Int) data Architecture = Arch { - archName :: String, - archDefaultSize :: Int, - archInitialPast :: [BindVar] -> Past, - archCompileCase :: [Int] -> (Int -> ((Int,Int),Past)) -> AllocInstr, - archCompileBuiltin :: Builtin -> ID -> [Value] -> AllocInstr + archName :: String, + archDefaultSize :: Int, + archInitials :: [BindVar] -> BindVar -> (Past,Future), + archCompileInstr :: Instruction -> ReaderT Info (TimeLine Past Future) (Int,Int,IO ByteString) } data Past = Past { - addresses :: Map ID Address, - bindings :: Map ID Register, - clobber :: Map ID [ID], - stack :: [(Bool,Int)] + registers :: Map ID Register, + stackAddrs :: Map ID Int, + stack :: [(Bool,Int)] } data Future = Future { - fregs :: Map ID Register + fregisters :: Map ID Register } -type Allocate = TimeLine Past Future -type AllocInstr = Monad m => Allocate (Int,m ByteString) +data Info = Info { + idValue :: ID -> IO Int, + bindings :: Map ID (ID,Int), + actives :: Set ID, + clobbers :: Relation ID ID, + branchPos :: Int -> (Int,Int,Maybe Past) + } + +stackF = Field (stack,\s p -> p { stack = s }) +bindingsF = Field (bindings,\a p -> p { bindings = a }) + +emptyFuture = Future Data.Map.empty diff --git a/src/Specialize/X86.hs b/src/Specialize/X86.hs deleted file mode 100644 --- a/src/Specialize/X86.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Specialize.X86 where - -specializeInstr (Op b vs v) info = do - diff --git a/src/Specialize/X86_64.hs b/src/Specialize/X86_64.hs new file mode 100644 --- /dev/null +++ b/src/Specialize/X86_64.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE RankNTypes, ViewPatterns #-} +module Specialize.X86_64(arch_x86_64) where + +import Specialize.Types +import Control.Monad +import qualified Data.ByteString as B +import Data.Bits +import My.Data.List +import Data.Char +import Data.Maybe +import Data.Ord + +import My.Prelude + +defSize = 8 +arch_x86_64 = Arch "x86_64" defSize defaults compile + +fromFields fs = foldl1 xor (zipWith shiftL (map (fromIntegral . fst) fs) (scanl (+) 0 $ map snd fs)) + +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]) +argBytes = argBytesWide True +argBytesWide w r rm arg = (pre,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 + (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) + 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 + 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 + 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 + (pre,suf) | code==0xC7 = argBytes 0 d Nothing + | otherwise = (fst $ argBytes d 0 Nothing,[]) +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 + 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) + +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 + 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])]) + 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 + +(e,s,c) <++> (e',s',c') = (e+e',s+s',liftM2 B.append c c') + +defaults args ret = undefined +compile = undefined diff --git a/src/Translate.hs b/src/Translate.hs --- a/src/Translate.hs +++ b/src/Translate.hs @@ -11,8 +11,8 @@ instance Translatable ID where translate = ($) -instance Translatable IDRange where - translate t (IDRange (a,b)) = IDRange (t a,t b) +instance Translatable a => Translatable (Range a) where + translate t (Range (a,b)) = Range (translate t a,translate t b) instance Translatable e => Translatable [e] where translate tr l = map (translate tr) l instance Translatable C.Value where @@ -22,7 +22,7 @@ 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 (Bind bv v) = Bind (translate tr bv) (fmap (translate tr) v) translate tr Noop = Noop instance Translatable PCode.Value where translate tr (SymVal t id) = SymVal t (translate tr id)