packages feed

alpha 0.9.8 → 0.9.9

raw patch · 20 files changed

+367/−136 lines, 20 filesdep +relation

Dependencies added: relation

Files

alpha.cabal view
@@ -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
src/Alpha.hs view
@@ -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
src/Compile.hs view
@@ -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)
src/Compile/State.hs view
@@ -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<length alts then tail alts!!i else head alts)+    IntVal (fromIntegral -> i) -> makeAlt 0 (if i+1<length alts then tail alts!!i else head alts)     _        -> sequence_ $ zipWith makeAlt [0..] alts             return (NullVal,([br],[]))
src/Context/Language.hs view
@@ -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)
src/Context/Types.hs view
@@ -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,
src/ID.hs view
@@ -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 <marc.coiffier@gmail.com> -- All rights reserved.
src/My/Control/Monad/TimeLine.hs view
@@ -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
+ src/My/Data/Either.hs view
@@ -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
src/My/Data/List.hs view
@@ -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 <marc.coiffier@gmail.com> -- All rights reserved.
src/My/Data/Tree.hs view
@@ -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 []]]
src/PCode/Instruction.hs view
@@ -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
src/PCode/Value.hs view
@@ -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
src/Serialize.hs view
@@ -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
src/Specialize.hs view
@@ -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]
src/Specialize/Architecture.hs view
@@ -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 = "#<Arch:"++archName 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" }
src/Specialize/Types.hs view
@@ -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
− src/Specialize/X86.hs 
@@ -1,4 +0,0 @@-module Specialize.X86 where--specializeInstr (Op b vs v) info = do-
+ src/Specialize/X86_64.hs view
@@ -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
src/Translate.hs view
@@ -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)