alpha 1.0 → 1.0.1
raw patch · 17 files changed
+501/−407 lines, 17 filesdep −relation
Dependencies removed: relation
Files
- alpha.cabal +4/−3
- src/Alpha.hs +2/−2
- src/Compile.hs +1/−1
- src/Compile/State.hs +19/−17
- src/Compile/Utils.hs +6/−5
- src/Context.hs +11/−11
- src/Context/Language.hs +2/−2
- src/Context/Types.hs +6/−6
- src/My/Control/Monad/RWTL.hs +2/−6
- src/My/Control/Monad/State.hs +19/−16
- src/My/Data/Relation.hs +56/−0
- src/Options.hs +2/−3
- src/PCode/Instruction.hs +1/−2
- src/Specialize.hs +9/−5
- src/Specialize/Types.hs +35/−16
- src/Specialize/X86_64.hs +135/−312
- src/Specialize/X86_64/Binary.hs +191/−0
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 1.0+version: 1.0.1 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time@@ -20,9 +20,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, AvlTree, COrdering+ build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, AvlTree, COrdering 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.RWTL 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+ other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Elf ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate hs-source-dirs: src c-sources: src/writeElf.c+
src/Alpha.hs view
@@ -58,8 +58,8 @@ interactive = void $ compileFile "/dev/stdin" compileProgram (language,root) = withDefaultContext entry $ do importLanguage compileLanguage (const $ return ()) language- l <- doF languageF get- rootSym <- stateF languageF $ internSym root+ l <- viewing language_ get+ rootSym <- viewState language_ $ internSym root getAddressComp (outputArch opts) rootSym (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses top <- gets compTop
src/Compile.hs view
@@ -124,7 +124,7 @@ compileExpr args ret expr = do args <- mapM bindFromSyntax args (code,imps) <- lift $ compile args ret expr- modifyF importsF (imps++)+ modifying imports_ (imps++) return code compileValue dest val = do c <- singleCode $< case dest of
src/Compile/State.hs view
@@ -3,7 +3,7 @@ module Context, module My.Data.Graph, CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..),- depGraphF,infoStackF,importsF,+ depGraph_,infoStack_,imports_, newVar, pushInfo,popInfo,topInfo,withInfo,withTopInfo, defaultState,@@ -19,6 +19,8 @@ ) where +import Control.Category ((>>>))+ import PCode import My.Control.Monad.State import My.Control.Monad@@ -52,22 +54,22 @@ } deriving Show -depGraphF = Field (depGraph,(\g cs -> cs { depGraph = g }))-infoStackF = Field (infoStack,(\l cs -> cs { infoStack = l }))-importsF = Field (imports,(\l cs -> cs { imports = l }))+depGraph_ = View (depGraph,(\g cs -> cs { depGraph = g }))+infoStack_ = View (infoStack,(\l cs -> cs { infoStack = l }))+imports_ = View (imports,(\l cs -> cs { imports = l })) defaultState = CS [] [] G.empty singleCode n = ([n],[n]) isBackEdge (_,BranchAlt Backward _) = True isBackEdge _ = False -getSymName = lift . gets . L.lookupSymName-getSymVal s = lift $ getsF valsF $ M.lookup s-newVar = lift $ state createSym+getSymName = lift . gets . L.lookupSymName+getSymVal s = lift $ getting (vals_ >>> f_ (M.lookup s))+newVar = lift $ state createSym -pushInfo = modifyF infoStackF . (:)-popInfo = stateF infoStackF (\(h:t) -> (h,t))-topInfo = getsF infoStackF head+pushInfo = modifying infoStack_ . (:)+popInfo = viewState infoStack_ (\(h:t) -> (h,t))+topInfo = getting (infoStack_ >>> f_ head) withTopInfo i x = pushInfo i >> x >>= \v -> popInfo >> return v withInfo f = popInfo >>= \i -> f i >>= \ret -> pushInfo i >> return ret @@ -75,14 +77,14 @@ nullCode = nullCodeVal NullVal nullCodeVal v = mkNoop >>= \n -> return (v,singleCode n) -getNodeList = getsF depGraphF nodeList-getContext n = getsF depGraphF (G.getContext n)+getNodeList = getting (depGraph_ >>> f_ nodeList)+getContext n = getting (depGraph_ >>> f_ (G.getContext n)) -createNode x = stateF depGraphF (G.insertNode x)-deleteNode n = modifyF depGraphF (G.deleteNode n)-modifyNode n f = modifyF depGraphF (G.modifyNode n f)-createEdge x n1 n2 = modifyF depGraphF (G.insertEdge x n1 n2)-deleteEdge n1 n2 = modifyF depGraphF (G.deleteEdge n1 n2)+createNode x = viewState depGraph_ (G.insertNode x)+deleteNode n = modifying depGraph_ (G.deleteNode n)+modifyNode n f = modifying depGraph_ (G.modifyNode n f)+createEdge x n1 n2 = modifying depGraph_ (G.insertEdge x n1 n2)+deleteEdge n1 n2 = modifying depGraph_ (G.deleteEdge n1 n2) makeTimeDep a b = do (v,(_in,_out)) <- a
src/Compile/Utils.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TupleSections, ViewPatterns, NoMonomorphismRestriction #-} module Compile.Utils where +import Control.Category ((>>>)) import Compile.State as CS import Data.Array import Data.Function@@ -24,7 +25,7 @@ t = spanningTree 0 nexts ; code' = flatten t a = array bounds (zip code' [0..]) -uniquify a r [] = uniquify a r [ret]+uniquify a r [] = uniquify a r [Branch NullVal []] uniquify args ret code = do ret <- descendM uniq (M.fromList $ zip syms syms) $ spanningTree 0 nexts return (flatten ret)@@ -34,7 +35,7 @@ news <- mapM (const $ state createSym) (bindSyms bv) let m' = foldr (uncurry M.insert) m (zip (bindSyms bv) news) return (Bind (translate (translateBy m') bv) (fmap (translateBy m) v),m')- uniq i m = return (onF fstF (translate (translateBy m)) $ withLocals m $ instr i)+ uniq i m = return (translate (translateBy m) `on_` fst_ $ withLocals m $ instr i) localVal m (SymVal t s) | (t==Value || t==Address) && not (M.member s m) = SymVal GValue s localVal m v = v translateBy m s = fromMaybe s $ M.lookup s m@@ -44,7 +45,7 @@ simplify :: Monad m => [Node] -> StateT CompileState m [Node] simplify start = do- oldDep <- getF depGraphF ; purgeAll ; newDep <- getF depGraphF+ oldDep <- getting depGraph_ ; purgeAll ; newDep <- getting depGraph_ return $ concatMap (newStart oldDep newDep) start where purgeAll = do@@ -84,7 +85,7 @@ instr :: NodeData } deriving Show-linearize start = getsF depGraphF (linearize' start)+linearize start = getting (depGraph_ >>> f_ (linearize' start)) linearize' start depG = instrs where aG = annotate depG@@ -102,7 +103,7 @@ ANode { instr = BrPart v } -> [Branch v $ map branch (classesBy (===) oes)] where branch ns = minimum $ catMaybes [M.lookup n instrMap | (n,_) <- ns] (===) = (==)`on`snd- ANode { instr = Instr i } -> i : if null oes then [ret] else []+ ANode { instr = Instr i } -> i : if null oes then [Branch NullVal []] else [] where oes = outEdges c selectHeads l = [n | (n,c) <- l, weight (tag c)==1]
src/Context.hs view
@@ -72,13 +72,13 @@ foreign import ccall "&nameSym_" nameSym_ptr :: FunPtr (Ptr Word8 -> IO ID) nameSym_ p = do l <- peekArray0 0 p- stateF languageF (internSym $ map w2c l)+ viewState language_ (internSym $ map w2c l) foreign export ccall "createSym_" createSym_ :: IO ID foreign import ccall "&createSym_" createSym_ptr :: FunPtr (IO ID)-createSym_ = stateF languageF createSym+createSym_ = viewState language_ createSym foreign export ccall "numSym_" numSym_ :: Int -> IO ID foreign import ccall "&numSym_" numSym_ptr :: FunPtr (Int -> IO ID)-numSym_ = stateF languageF . internSym . show+numSym_ = viewState language_ . internSym . show foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ()) foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ()))@@ -158,15 +158,15 @@ initialContext entry = C lang jitA M.empty (fromIntegral entry) Nothing where (lang,jitA) = execState (mapM_ st initialBindings) (Lang.empty,M.empty) where st (s,v) = do- i <- stateF fstF (internSym s)+ i <- viewState fst_ (internSym s) case v of- Left v -> modifyF fstF (setSymVal i v)- Right p -> modifyF sndF (M.insert i p)+ Left v -> modifying fst_ (setSymVal i v)+ Right p -> modifying snd_ (M.insert i p) withDefaultContext = withState . initialContext contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a-languageState = contextState . doF languageF+languageState = contextState . viewing language_ pageSize = fromIntegral $ unsafePerformIO $ c'sysconf c'_SC_PAGESIZE enableExec p size = do@@ -204,11 +204,11 @@ where lookup id = do val <- M.lookup id $< gets jitAddresses return $ (fromIntegral . ptrToIntPtr . unsafeForeignPtrToPtr) $< val- register id ptr size = modifyF jitAddressesF (M.insert id ptr)+ register id ptr size = modifying jitAddresses_ (M.insert id ptr) getAddressComp arch = getAddress arch lookup register where lookup id = (fst$<) $< M.lookup id $< gets compAddresses register id ptr size = do- n <- getF compTopF- modifyF compAddressesF (M.insert id (n,ptr))- modifyF compTopF (+size)+ n <- getting compTop_+ modifying compAddresses_ (M.insert id (n,ptr))+ modifying compTop_ (+size)
src/Context/Language.hs view
@@ -48,7 +48,7 @@ where st (Just id) = return id st _ = do i <- state createSym - modifyF symsF (BM.insert s i) + modifying syms_ (BM.insert s i) return i envCast t = T.mapM (state . intern) t@@ -69,7 +69,7 @@ mergeLanguage imp l' loadImport l' return $ comp || recomp- mergeLanguage imp l' = doF languageF $ do+ mergeLanguage imp l' = viewing language_ $ do let Language { symbolsL = syms' , languagesL = mods' , maxIDL = mi' } = l' mapM_ (state . internSym) $ BM.keys syms' Language { maxIDL = mi, symbolsL = syms } <- get
src/Context/Types.hs view
@@ -34,8 +34,8 @@ exportsL :: Set ID, initializeL :: [Code] }-symsF = Field (symbolsL,\s ce -> ce { symbolsL = s })-valsF = Field (valuesL,\v ce -> ce { valuesL = v })+syms_ = View (symbolsL,\s ce -> ce { symbolsL = s })+vals_ = View (valuesL,\v ce -> ce { valuesL = v }) data Context = C { language :: Language,@@ -44,7 +44,7 @@ compTop :: Int, transform :: Maybe (Ptr ()) }-jitAddressesF = Field (jitAddresses,\a c -> c { jitAddresses = a })-compAddressesF = Field (compAddresses,\a c -> c { compAddresses = a })-languageF = Field (language,\a c -> c { language = a })-compTopF = Field (compTop,\a c -> c { compTop = a })+jitAddresses_ = View (jitAddresses,\a c -> c { jitAddresses = a })+compAddresses_ = View (compAddresses,\a c -> c { compAddresses = a })+language_ = View (language,\a c -> c { language = a })+compTop_ = View (compTop,\a c -> c { compTop = a })
src/My/Control/Monad/RWTL.hs view
@@ -47,9 +47,5 @@ future st = RWTL (\r p f -> let (p',_,~(a,f'),w) = runRWTL (runStateT st f) r p f in (p',f',a,w)) -listening m = censor (const mempty) $ do (_,w) <- listen m ; return w-withFuture m = future (do f <- get- f' <- lift $ future get- ret <- lift $ m f- put f'- return ret)+listening = censor (const mempty) . listen+withFuture m = future (get >>= \f -> lift (liftM2 (,) (m f) (future get)) >>= state . const)
src/My/Control/Monad/State.hs view
@@ -1,30 +1,33 @@ {-# LANGUAGE TupleSections, NoMonomorphismRestriction #-} module My.Control.Monad.State( module Control.Monad.State, - Field(..),(<.>),- stateF,doF,modifyF,getF,getsF,putF,swapF,- fstF,sndF,onF,+ View(..),+ viewState,viewing,modifying,getting,putting,+ fst_,snd_,id_,f_,on_, withState ) where +import Prelude hiding ((.),id) import Control.Monad.State hiding (withState)--newtype Field f s = Field (s -> f,f -> s -> s)+import Control.Category -fstF = Field (fst,(\x ~(a,b) -> (x,b))) :: Field a (a,b)-sndF = Field (snd,(\y ~(a,b) -> (a,y))) :: Field b (a,b)+newtype View a v = View (a -> v,v -> a -> a)+instance Category View where+ id = id_+ View (u,u') . View (v,v') = View (u . v, \x a -> v' (u' x (v a)) a) -stateF (Field (m,m')) st = get >>= \s -> let ~(v,st') = st (m s) in put (m' st' s) >> return v-doF f st = stateF f (runState st)-modifyF fld f = stateF fld (\s -> ((),f s))-getF (Field (f,_)) = gets f -getsF (Field (f,_)) g = gets (g . f)-putF f v = modifyF f (const v)-swapF f v = stateF f (,v) +fst_ = View (fst,(\x ~(a,b) -> (x,b)))+snd_ = View (snd,(\y ~(a,b) -> (a,y)))+id_ = View (id,const)+f_ f = View (f,error "undefined function view") -Field (f,f') <.> Field (g,g') = Field (g . f, (\g s -> f' (g' g (f s)) s)) +viewState (View (v,v')) run = state (\s -> let ~(x,s') = run (v s) in (x,v' s' s))+viewing v st = viewState v (runState st)+modifying v f = viewState v (\s -> ((),f s))+getting (View (f,_)) = gets f +putting f v = modifying f (const v) -onF (Field (t,t')) f x = t' (f (t x)) x+f `on_` View (v,v') = \x -> v' (f (v x)) x withState s mx = get >>= \v -> put s >> mx >>= \x -> put v >> return x
+ src/My/Data/Relation.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module My.Data.Relation(Relation+ ,empty,singleton,fromList,toList+ ,inverse+ ,insert,delete+ ,member,notMember+ ,lookupRan,lookupDom,range,domain+ ,modifyRan,modifyDom,setRan,setDom+ ,filterDom,filterRan) where++import Control.Monad.State+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe++data Relation a b = Relation {+ ranges :: M.Map a (S.Set b),+ domains :: M.Map b (S.Set a)+ }+ deriving Show++empty = Relation M.empty M.empty+singleton a b = insert a b empty+fromList = foldr (uncurry insert) empty+toList r = [(a,b) | (a,bs) <- M.assocs (ranges r), b <- S.toList bs]++inverse (Relation a b) = Relation b a++insertVal a b m = M.alter (Just . S.insert b . fromMaybe S.empty) a m+deleteVal a b m = M.alter (mfilter (not . S.null) . fmap (S.delete b)) a m++insert a b (Relation ran dom) = Relation (insertVal a b ran) (insertVal b a dom)+delete a b (Relation ran dom) = Relation (deleteVal a b ran) (deleteVal b a dom)++member a b r = S.member b (lookupRan a r)+notMember a b = not . member a b++lookupRan a r = fromMaybe S.empty $ M.lookup a (ranges r)+range = S.unions . M.elems . ranges+lookupDom b = lookupRan b . inverse+domain = range . inverse++modifyRan f a r = r {+ ranges = M.alter (const $ if S.null newRan then Nothing else Just newRan) a (ranges r),+ domains = execState st (domains r)+ }+ where newRan = f oldRan ; oldRan = lookupRan a r+ st = sequence_ [modify (deleteVal b a) | b <- S.toList $ oldRan S.\\ newRan]+ >> sequence_ [modify (insertVal b a) | b <- S.toList $ newRan S.\\ oldRan]+modifyDom f b r = inverse (modifyRan f b (inverse r))++setRan a = flip modifyRan a . const+setDom b = flip modifyDom b . const++filterRan p r = inverse (filterDom p (inverse r))+filterDom p (Relation ran dom) = Relation (M.filterWithKey (const . p) ran) (M.map (S.filter p) dom)
src/Options.hs view
@@ -1,4 +1,4 @@-module Options (Architecture(..),Action(..),Settings(..),Format(..),helpMsg,getSettings) where+module Options (Action(..),Settings(..),Format(..),helpMsg,getSettings) where import Specialize.Architecture import System.Console.GetOpt@@ -28,7 +28,6 @@ splitArg s = case break (==':') s of (a,':':b) -> a:splitArg b- ("","") -> [] (a,"") -> [a] options = @@ -58,7 +57,7 @@ glue [a,_] t = a++" or "++t glue (a:_) t = a++", "++t sep = Option [] [] undefined "-----------------"-helpMsg = usageInfo "Usage: alpha (<option>|<language>:<symbol>)..." options+helpMsg = usageInfo "Usage: alpha <option>... <language>:<symbol>..." options defaultSettings progs = Settings Compile ["."] "." (map readProg progs) hostArch Elf64 where readProg p = case splitArg p of
src/PCode/Instruction.hs view
@@ -50,8 +50,7 @@ | 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 []+-- ret = Branch NullVal [] isRet (Branch NullVal []) = True isRet _ = False
src/Specialize.hs view
@@ -12,6 +12,7 @@ import ID import My.Control.Monad import My.Control.Monad.State+import My.Control.Monad.RWTL import My.Data.Either import My.Data.List import My.Data.Tree@@ -21,7 +22,7 @@ import Specialize.Types import qualified Data.ByteString as B import qualified Data.Map as M-import qualified Data.Relation as R+import qualified My.Data.Relation as R import qualified Data.Set as S import System.IO.Unsafe@@ -68,7 +69,7 @@ | 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)+ instr = gens'!g ; newFut = Future $ locations $ fst (instrs!instr) changeFuture i g f = puti i (g,f) >> mapM_ propagate (prevs i) propagate i = do let j = head (nexts i)@@ -98,7 +99,7 @@ addActives (Branch (SymVal Value id) _) s = S.insert id s 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)+ clobbers i v = ifEmpty (S.singleton v) $ R.lookupRan v (clobbersA!i) clobbersA = treeArray next (insertManyA (R.singleton worldID worldID) [(bindSym bv,s) | bv <- maybe id (:) retVar args , bv <- bindNodes bv@@ -115,14 +116,17 @@ , a <- [(v,worldID),(v,v)]] next _ r _ = r insertManyA r as = insertManyR r [a | (x,y) <- as, a <- [(x,y),(y,x)]]- lookupRefs v r = fromMaybe (S.singleton worldID) $ R.lookupRan v r+ lookupRefs v r = ifEmpty (S.singleton worldID) $ R.lookupRan v r argRefs i vs = S.toList $ S.fromList [s | SymVal Address s <- vs] <> S.unions [references i s | SymVal Value s <- vs] references i v = lookupRefs v (referencesA!i) referencesA = treeArray next $ insertManyR R.empty [(s,worldID) | arg <- args, s <- bindSyms arg] where next i r (Op _ v vs) = insertManyR r' (map (v,) $ argRefs i vs)- where r' = foldr (uncurry R.delete) r [(v,v') | v' <- maybe [] S.toList $ R.lookupRan v r]+ where r' = foldr (uncurry R.delete) r [(v,v') | v' <- S.toList $ R.lookupRan v r] next _ r _ = r++ifEmpty def s | S.null s = def+ | otherwise = 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]
src/Specialize/Types.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE RankNTypes #-}-module Specialize.Types(module Data.Word, module My.Control.Monad.RWTL- ,module PCode, module ID,module Specialize.Frame- ,Register(..),BinCode(..), isEmptyCode, binCodeData+module Specialize.Types(BinCode(..), isEmptyCode, binCodeData ,Architecture(..) ,Info(..)- ,MemState(..),Future(..), emptyFuture- ,frameF, registersF, changedF, fregistersF) where+ ,Location(..), isFlags, regSyms, symLocs, symReg+ ,MemState(..), Future(..), emptyFuture+ ,frame_, locations_, flocations_) where +import Data.Ord import Data.Bimap import Data.Set import Data.ByteString import Data.Map-import Data.Relation-import Data.Set+import My.Data.Relation as R+import Data.Set as S import Data.Word import ID import My.Control.Monad.State@@ -30,7 +30,20 @@ isEmptyCode (BC (e,_,_)) = e==0 binCodeData (BC (_,_,b)) = b -type Register = Int+data Location = Register Int+ | Memory+ | Constant Integer+ | Flags Int+ deriving Show+instance Eq Location where+ a == b = compare a b == EQ+instance Ord Location where+ compare = comparing value+ where value (Register r) = (0,Just $ fromIntegral r)+ value Memory = (1,Nothing)+ value (Constant n) = (2,Just n)+ value (Flags _) = (3,Nothing)+ data Architecture = Arch { archName :: String, archDefaultSize :: Int,@@ -38,13 +51,12 @@ archCompileInstr :: Instruction -> RWTL Info BinCode MemState Future () } data MemState = MemState {- registers :: Bimap ID Register,- changed :: Set ID,+ locations :: Relation ID Location, frame :: Frame } deriving Show data Future = Future {- fregisters :: Bimap ID Register+ flocations :: Relation ID Location } deriving Show data Info = Info {@@ -63,9 +75,16 @@ ++", clobbers = "++show c ++" }" -registersF = Field (registers ,\r p -> p { registers = r })-changedF = Field (changed ,\c p -> p { changed = c })-frameF = Field (frame ,\f p -> p { frame = f })-fregistersF = Field (fregisters ,\r f -> f { fregisters = r })+locations_ = View (locations ,\r p -> p { locations = r })+frame_ = View (frame ,\f p -> p { frame = f })+flocations_ = View (flocations ,\r f -> f { flocations = r }) -emptyFuture = Future Data.Bimap.empty+regNum (Register r) = Just r+regNum _ = Nothing+isFlags (Flags _) = True ; isFlags _ = False++regSyms r locs = S.toList $ R.lookupDom (Register r) locs+symLocs s locs = S.toList $ R.lookupRan s locs+symReg s locs = msum [regNum l | l <- symLocs s locs]++emptyFuture = Future R.empty
src/Specialize/X86_64.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE ViewPatterns, TupleSections, ParallelListComp, ImplicitParams, NoMonomorphismRestriction #-} module Specialize.X86_64(arch_x86_64,execStub,initStub,callStub0,callStub1) where -import Control.Monad.Writer.Class- import Control.Arrow import Control.Monad.Reader import Control.Monad.Trans@@ -13,241 +11,67 @@ import Data.Maybe import Data.Monoid import Data.Ord+import ID import My.Control.Monad+import My.Control.Monad.RWTL import My.Control.Monad.State import My.Data.Either import My.Data.List import My.Prelude-import Specialize.Types hiding (call)+import PCode+import Specialize.Frame+import Specialize.Types+import Specialize.X86_64.Binary+import qualified Data.Bimap as BM 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.Relation as R import qualified My.Data.SetBy as SB -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))] -> (Int,IO Integer) -> Maybe (Word8,Int,Int,IO [Word8])- arch_x86_64 = Arch "x86_64" defSize defaults compile-(execStub,initStub, callStub0, callStub1) = (writerStub exec,writerStub init,- writerStub . callStub0,writerStub . callStub1)- where cStub loadArgs = do- mapM_ push saved- loadArgs- call rdi- mapM_ pop saved- tellCode [0xc3]- alphaStub loadArgs f = do- loadArgs- movi r14 (withSize (f :: Integer))- call r14- tellCode [0xc3]- saved = rbx:rbp:[r12..r15]- init = cStub (mov rdx rsi)- exec = cStub (return ())- callStub0 = alphaStub (return ())- callStub1 = alphaStub (mov rdi rdx)- push r = tellCode $ pre++[0x50.|.(fi r.&.7)]- where (pre,_) = argBytesWide False 0 r Nothing- pop r = tellCode $ pre++[0x58.|.(fi r.&.7)]- where (pre,_) = argBytesWide False 0 r Nothing- writerStub stub = let BC (_,_,code) = execWriter stub in code -defSize = 8-([rax,rcx,rdx,rbx,rsp,rbp,rsi,rdi,r8,r9,r10,r11,r12,r13,r14,r15],allocRegs) =- (regs,filter isAllocReg regs)- where regs = [0..15] :: [Int]+allocRegs = filter isAllocReg registers isAllocReg r = (r>=rax && r<rsp) || (r>rdi && r<=r15) oppFlags f = fromJust $ lookup f $ fls++map swap fls where fls = [(0xf,0xc),(0x4,0x5),(0xd,0xe)] -fis = fmap fromIntegral ; fi = fromIntegral k = Kleisli a <|||> b = runKleisli (k a ||| k b) leftK f = runKleisli (left $ k f) -bSize (bindSize -> (n,nr)) = n+nr*defSize-numSize n | n>=0 = numSize 64 n- | otherwise = 1+numSize 64 (-1-n)- where numSize 0 _ = 1- numSize bl n = case reverse $ takeWhile (>0) $ iterate (`shiftR`bl) n of- [] -> 0- (x:t) -> (length t)*bl + numSize (bl`div`2) x-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)--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 = (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 ++ 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,[n])- | otherwise = (2,take 4 $ bytes n)- sib | mode/=3 && (rm.&.7 == 4) = [fromFields [(4,3),(4,3),(0,2)]]- | otherwise = []--op code d a b | d==b = op d a- | otherwise = mov d a >> op d b- where op d a = tellCode $ pre++code++suf- where (pre,suf) = argBytes d a Nothing-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 rsi n >> op def d a rsi-codeFun codes (size,n) = listToMaybe [(code,r,count,imm count) | (s,(code,count,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,_) = bwxorrr d d d-movi d n = tell $ fromBytesN (length pref+s) (liftM (pref++) imm)- where (code,r,s,imm) = fromJust $ codeFun [(31,(0xC7,4,0)),(64,(0xB8`xor`(fi d.&.7),8,0))] n- (pre,suf) | code==0xC7 = argBytes 0 d Nothing- | 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)-zxtnd r s = case (s :: Int) of- 1 -> tellCode (pre++[0x0f,0xb6]++post)- 2 -> tellCode (pre++[0x0f,0xb7]++post)- _ -> shli r r sz >> shri r r sz- where sz = withSize $ 8*(defSize-s)- where (pre,post) = argBytes r r Nothing-sxtnd r s = case (s :: Int) of- 1 -> tellCode (pre++[0x0f,0xbe]++post)- 2 -> tellCode (pre++[0x0f,0xbf]++post)- 4 -> tellCode (pre++[0x63]++post)- _ -> shli r r sz >> sari r r sz- where sz = withSize $ 8*(defSize-s)- where (pre,post) = argBytes r r Nothing- -setcc r f = tellCode (pre++[0x0f,0x90.|.fi f]++post) >> zxtnd r 1- where (pre,post) = argBytesWide False 0 r Nothing--shli = opi (codeFun [(8,(0xC1,1,4))]) undefined-shri = opi (codeFun [(8,(0xC1,1,5))]) undefined-sari = opi (codeFun [(8,(0xC1,1,7))]) undefined-rori d s n | n==0||n==64 = return ()- | otherwise = opi (codeFun [(8,(0xC1,1,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 = sequence_ $ zipWith ldChunk (reverse $ zip (sums szs) szs) (True:repeat False)- ldChunk (i,sz) fst = sh sz >> tellCode (pre'++pre++code++suf)- where (pre,suf) = argBytesWide (sz==8) d s (Just (n+i))- (pre',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 = sequence_ $ reverse [stChunk a b | (a,b) <- zip (reverse $ zip (sums szs) szs) (True:repeat False)]- stChunk (i,sz) lst = tellCode (pre'++pre++code++suf) >> sh sz- where (pre,suf) = argBytesWide (sz==8) s d (Just (n+i))- (pre',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)--commOp c c' = (op c,opn,flip . opn)- where opn = opi (codeFun c') c--addri d r (0,_) = return ()-addri d r v = addri' d r v-(addrr,addri',addir) = commOp [0x03] [(8,(0x83,1,0)),(32,(0x81,4,0))]-(mulrr,mulri,mulir) = commOp [0x0F,0xAF] [(8,(0x6B,1,0)),(64,(0x69,8,0))]-(bwandrr,bwandri,bwandir) = commOp [0x23] [(7,(0x83,1,4)),(31,(0x81,4,4))]-(bworrr,bworri,bworir) = commOp [0x0b] [(7,(0x83,1,1)),(31,(0x81,4,1))]-(bwxorrr,bwxorri,bwxorir) = commOp [0x33] [(7,(0x83,1,6)),(31,(0x81,4,6))]-notr r = tellCode $ pre++[0xf7]++post- where (pre,post) = argBytes 2 r Nothing-negr r = tellCode $ pre++[0xf7]++post- where (pre,post) = argBytes 3 r Nothing-subrr d a b | d==b = op [0x2b] d d a >> negr d- | otherwise = op [0x2b] d a b-subri d r (0,_) = return ()-subri d r v = opi (codeFun [(8,(0x83,1,5)),(32,(0x81,4,5))]) [0x2b] d r v-subir d n a | d==a = subri d d n >> negr d- | otherwise = movi d n >> subrr d d a--cmprr _ a b = op [0x3b] a a b-cmpri _ a = opi (codeFun codes) [0x3b] a a- where codes = [(8,(0x83,1,7)),(32,(0x81,4,7))]-cmpir _ n a = movi rsi n >> cmprr rsi rsi a--calli pos (size,v) = tell $ fromBytesN 5 $ do- pos <- pos ; v <- v- -- putStrLn $ "calli: size="++show size++" pos="++show pos++" dest="++show v- return $ [0xe8]++take 4 (bytes (v-fi pos-5))-call r = tellCode $ pre++[0xff]++post- where (pre,post) = argBytesWide False 2 r Nothing--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 (min s s',liftM2 ii n n')- argVal (IntVal n) = Right $ withSize n argVal (SymVal Size s) = Right $ withSize $ fromMaybe defSize $ M.lookup s (sizes ?info) argVal (SymVal SymID (ID s)) = Right $ withSize $ s argVal (SymVal GValue s) = Right (defSize*8,toInteger $< snd (envInfo ?info) s)-argVal (SymVal _ s) = Left s+argVal (SymVal t s) = Left (t,s)+valSym (SymVal Value s) = Just s+valSym _ = Nothing binding s = M.lookup s (bindings ?info) isActive s = S.member s (actives ?info) varSize s = fromMaybe defSize (M.lookup s $ sizes ?info) -argSize (SymVal Value s) = varSize s-argSize _ = defSize+argSize = maybe defSize varSize . valSym verbAddress = let (me,addrs) = envInfo ?info in addrs me instrAddress i = let (_,addrs) = branchPos ?info ; (e,s,_) = addrs i in (e,s) instrPast i = let (_,addrs) = branchPos ?info ; (_,_,p) = addrs i in p thisInstr = fst $ branchPos ?info -associate r s = modifyF registersF (maybe BM.deleteR BM.insert s r)-frameAddr s = stateF frameF (withAddr defSize s)+frameAddr s = viewState frame_ (withAddr defSize s) stackAddr sz = liftM (frameToStack sz) . frameAddr frameToStack sz n = -(n+sz)-lookupSymIn = flip BM.lookupR-lookupRegIn = flip BM.lookup-argValSym (SymVal Value s) = Just s-argValSym _ = Nothing-lookupArgReg arg m = argValSym arg >>= lookupRegIn m -withFreeSet m = liftM2 (,) get (future get) >>= \(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+associateLoc l s = modifying locations_ $ R.setDom l s+associateVar v s = modifying locations_ $ R.setRan v s+associateVL v l = associateVar v S.empty >> associateLoc l (S.singleton v)+associateReg = associateLoc . Register+associateVR v = associateVL v . Register++withFreeSet m = withFuture $ \f -> get >>= \p -> do+ let cmp r r' = compare (pCount r) (pCount r')+ `mappend` compare (fCount r) (fCount r')+ `mappend` compare r r'+ varCount r = S.size . R.lookupDom (Register r)+ pCount = flip varCount (locations p) ; fCount = flip varCount (flocations f) evalStateT m (SB.fromList cmp allocRegs) readFuture m = StateT s@@ -257,62 +81,62 @@ 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 (_,_,a,w) = runRWTL (runStateT m t) r p f in (p,f,a,w) )-regInfo = liftM2 (,) (gets registers) (asks (fregisters . snd))+locInfo = liftM2 (,) (gets locations) (asks (flocations . snd)) -allocReg sym = lift regInfo >>= \(_,regs) -> do+allocReg sym = lift locInfo >>= \(_,locs) -> do let st free = (r,SB.delete r free) where r | SB.null free = rdi- | otherwise = fromMaybe (SB.findMin free) $ mfilter (`SB.member`free)- $ lookupRegIn regs sym+ | otherwise = fromMaybe (SB.findMin free) $ mfilter (`SB.member`free) $ symReg sym locs state st -destRegister d = lift regInfo >>= \(regs,fregs) -> - case mfilter (\r -> maybe True (==d) $ BM.lookupR r regs) $ lookupRegIn fregs d of+destRegister d = lift locInfo >>= \(locs,flocs) -> + case mfilter (\r -> S.null $ S.delete d $ R.lookupDom (Register r) locs) $ symReg d flocs of Just r -> return r- Nothing -> case mfilter isAllocReg (findSym d) `mplus` find (isNothing . findReg) allocRegs of+ Nothing -> case mfilter isAllocReg (regOf d) `mplus` find (null . symsOf) allocRegs of Just r -> return r- Nothing -> storeRegs [head allocRegs] >> return (head allocRegs)- where findReg r = lookupSymIn regs r `mplus` lookupSymIn fregs r- findSym s = lookupRegIn regs s `mplus` lookupRegIn fregs s+ Nothing -> saveRegs [head allocRegs] >> return (head allocRegs)+ where symsOf r = regSyms r locs `mplus` regSyms r flocs+ regOf s = symReg s locs `mplus` symReg s flocs -loadRoot (Just s) = lift regInfo >>= \(regs,_) -> case lookupRegIn regs s of+loadRoot (Just s) = lift locInfo >>= \(locs,_) -> case symReg s locs of Just r -> return r Nothing -> do- r <- allocReg s- a <- lift (stackAddr defSize s)- lift $ associate r (Just s)+ r <- allocReg s ; a <- lift (stackAddr defSize s) ld r (rsp,fi a,defSize)+ lift $ associateReg r (S.singleton s) return r loadRoot Nothing = return rsp -storeRegs rs = lift regInfo >>= \(regs,_) -> do- let vars = [(r,s,binding s) | (r,Just s) <- zip rs (map (lookupSymIn regs) rs)]- parent (_,_,b) = fmap fst b- groups = classesBy ((==)`on`parent) vars- storeGroup g = do- ch <- lift $ gets (flip S.member . changed)- let loaded = [(ch s,ge) | ge@(_,s,_) <- g]- root <- if any fst loaded then loadRoot $ parent $ head g else return undefined- lift $ mapM_ (\(c,ge@(r,s,_)) -> when c (store root ge >> modifyF changedF (S.delete s))) loaded+saveRegs rs = lift locInfo >>= \(locs,_) -> saveVars $ concatMap (flip regSyms locs) rs+saveVars = saveVars' (\p s -> R.member s Memory (locations p) || S.size (R.lookupRan s (locations p)) > 1)+storeVars = saveVars' (\p s -> R.member s Memory (locations p))+saveVars' isSaved vs = lift locInfo >>= \(locs,_) -> do+ let assocs = [(r,s,binding s) | (s,Just r) <- zip vs (map (flip symReg locs) vs)]+ groups = classesBy ((==)`on`assocRoot) assocs+ assocRoot (_,_,b) = fmap fst b+ storeGroup group = do+ isSaved <- lift $ gets isSaved+ let loaded = [(isSaved s,a) | a@(_,s,_) <- group]+ when (any (not . fst) loaded) $ do+ root <- loadRoot $ assocRoot $ head group+ lift $ mapM_ (\(saved,a) -> unless saved (store root a)) loaded where store root (r,s,b) = do n <- maybe (stackAddr (varSize s) s) (return . snd) b st (root,fi n,fi (varSize s)) r+ modifying locations_ (R.insert s Memory) restrict m = gets (SB.partition isFree) >>= \(free',occ) -> put free' >> m >> modify (SB.union occ)- where isFree = isNothing . lookupSymIn regs+ where isFree r = null $ regSyms r locs restrict $ mapM_ storeGroup groups- lift $ mapM_ (\(r,_,_) -> associate r Nothing) vars loadArgs args = do- let modFRegs regs = foldr ($) regs [maybe (BM.deleteR r) (flip BM.insert r) $ argValSym arg- | (arg,Just r) <- args]- lift $ future $ modifyF fregistersF $ modFRegs+ let modFlocs = [maybe (R.setDom (Register r) S.empty) (\s -> R.insert s (Register r)) $ valSym arg | (arg,Just r) <- args]+ lift $ future $ viewing flocations_ $ mapM_ modify modFlocs readFuture $ do- (regs,_) <- lift regInfo+ (locs,_) <- lift locInfo let fixed = mapMaybe snd args argAlloc (arg,Nothing) = leftK f (argVal arg)- where f s = get >§ \free -> maybe (Left s) Right- $ mfilter (`SB.member` free) (BM.lookup s regs)+ where f (_,s) = get >§ \free -> maybe (Left s) Right $ mfilter (`SB.member` free) (symReg s locs) argAlloc (_,Just r) = return (Left $ Right r) argNew = leftK (allocReg <|||> return) modify $ SB.deleteMany fixed@@ -325,72 +149,69 @@ bind _ = Nothing groups = classesBy ((==)`on`parent) assocs parent (_,_,b) = fmap fst b- myWorkIsDone r s = BM.pairMember (s,r) regs+ myWorkIsDone r (_,s) = R.member s (Register r) locs loadGroup g = do base <- loadRoot (parent $ head g) mapM_ (load base) g where load base (r,arg,b) = do- storeRegs [r] ; lift $ do- case argVal arg of- Right v -> movi r v- Left s -> regInfo >>= \(regs,_) -> case (lookupRegIn regs s,symValType arg) of- (Just r',Value) -> mov r r'- (_,t) -> maybe (stackAddr (varSize s) s) return (fmap snd b) >>= \n -> case t of- Value -> ld r (base,fi n,fi (varSize s))- Address -> lea r base (fi n)- associate r $ (Just ||| const Nothing) (argVal arg) + saveRegs [r] ; lift $ case argVal arg of+ Right v -> movi r v >> associateReg r S.empty+ Left (t,s) -> locInfo >>= \(locs,_) -> case (symReg s locs,t) of+ (Just r',Value) -> mov r r' >> associateReg r (R.lookupDom (Register r') locs)+ (_,t) -> do+ n <- maybe (stackAddr (varSize s) s) (return . snd) b+ case t of+ Value -> ld r (base,fi n,fi (varSize s)) >> associateReg r (S.singleton s)+ Address -> lea r base (fi n) >> associateReg r S.empty mapM_ loadGroup groups return allocs -alignWith regs = do- loadArgs [(SymVal Value s,Just r) | (s,r) <- BM.toList regs]- free <- get- readFuture $ storeRegs (SB.toList free)+alignWith locs = do+ loadArgs [(SymVal Value s,Just r) | (s,Register r) <- R.toList locs]+ readFuture $ storeVars $ S.toList $ R.lookupDom Memory locs -defaults args ret = (MemState pregs (S.fromList $ map (bindSym . snd) regs) frame,Future fr)- where (regArgs,stArgs) = partition ((<=defSize) . bSize) args+defaults args ret = (MemState plocs frame,Future fr)+ where (regArgs,stArgs) = partition (bSize >>> (<=defSize)) args (regs,nonRegs) = zipRest argRegs regArgs (retReg:funReg:argRegs) = allocRegs- pregs = BM.fromList [(bindSym v,r) | (r,v) <- regs]+ plocs = R.fromList $ [(bindSym v,Register r) | (r,v) <- regs]+ ++ [(bindSym v,Memory) | v <- stArgs++nonRegs] frame = foldr (frameAlloc defSize) emptyFrame (stArgs++nonRegs) fr = case ret of- Just ret | bSize ret<=defSize -> BM.singleton (bindSym ret) retReg- _ -> BM.empty--storeFlags s = do- regs <- gets registers- withFreeSet $ readFuture $ case M.lookupGE 16 (BM.toMapR regs) of- Nothing -> doNothing- Just (rf,s') | s==Just s' -> doNothing- | isActive s' -> do- r <- destRegister s'- storeRegs [r]- setcc r rf- lift $ associate r (Just s')- | otherwise -> lift $ associate rf Nothing+ Just ret | bSize ret<=defSize -> R.singleton (bindSym ret) (Register retReg)+ _ -> R.empty -compile i = ask >>= \info -> let ?info = info in - listen (storeFlags (branchSym i)) >>= \(_,BC (e',s',_)) -> +storeFlags s = withFreeSet $ readFuture $ lift locInfo >>= \(locs,_) -> case R.lookupDom (Flags 0) locs of+ vs | S.null (maybe id S.delete s vs) -> doNothing+ | otherwise -> do+ let s = S.findMin vs+ Flags rf = fromJust (find isFlags $ symLocs s locs)+ r <- destRegister s+ saveRegs [r]+ setcc r rf+ lift $ modifying locations_ $ R.setDom (Register r) vs . R.setDom (Flags 0) S.empty+ +compile i = ask >>= \info -> do+ let ?info = info + (_,BC (e',s',_)) <- listen (storeFlags (branchSym i)) let ?info = info { branchPos = (thisInstr, \i -> let (e,s,p) = snd (branchPos ?info) i in (e+e',s+s',p)) }- in compile' i-+ compile' i+ modifying locations_ (R.filterDom isActive) where branchSym (Branch (SymVal Value s) _) = Just s branchSym _ = Nothing compile' (Op b d vs) = do- future $ modifyF fregistersF $ BM.delete d+ future $ modifying flocations_ $ R.setRan d S.empty compileOp b d vs flip evalStateT (SB.empty compare) $ readFuture $ do- (regs,_) <- lift regInfo- when (BM.member d regs) $ lift $ modifyF changedF (S.insert d)- storeRegs [r | (s,r) <- BM.toList regs, not (isActive s), isJust (binding s)]- lift $ modifyF registersF (BM.filter (const . isActive))+ (locs,_) <- lift locInfo+ saveVars [s | r <- allocRegs, s <- regSyms r locs, not (isActive s), isJust (binding s)] compile' (Branch v alts) = withFreeSet $ do- let alignPast i = listening $ maybe doNothing (\p -> preserve $ do- lift $ putF frameF (frame p)- alignWith $ registers p) (instrPast i)+ let alignPast i = snd $< listening $ maybe doNothing (\p -> preserve $ do+ lift $ putting frame_ (frame p)+ alignWith $ locations p) (instrPast i) jmpc short long (BC ~(e,s,_)) (BC ~(e',s',_)) = BC (length long+4,length code,return $ B.pack code) where de = e'-e ; ds = s'-s code | de==0 = []@@ -402,11 +223,11 @@ case alts of [] -> readFuture $ do p <- lift get- let isPresent s _ = or [M.member s (bindings ?info)- ,isJust $ lookupAddr s (frame p)- ,BM.member s (registers p)]- (_,fregs) <- lift regInfo- unReadFuture $ alignWith (BM.filter isPresent fregs)+ let isPresent s = or [M.member s (bindings ?info)+ ,isJust $ lookupAddr s (frame p)+ ,S.member s (R.domain $ locations p)]+ (_,flocs) <- lift locInfo+ unReadFuture $ alignWith (R.filterDom isPresent flocs) tellCode [0xc3] [def] -> do al <- alignPast def@@ -414,20 +235,20 @@ codes = [al,jmp p (start def)] mapM_ tell codes [def,null] -> do- (r,c) <- censor (const mempty) $ listen $ readFuture $ do- r <- lift $ gets (lookupArgReg v . registers)- case mfilter (>=16) r of- Just r -> return r+ (r,c) <- listening $ readFuture $ do+ rs <- lift $ gets (\p -> maybe [] (flip symLocs (locations p)) (valSym v))+ case find isFlags rs of+ Just f -> return f Nothing -> do [Left r] <- unReadFuture (loadArgs [(v,Nothing)]) cmpri r r (withSize (0 :: Int))- return r+ return (Register r) [al,al'] <- mapM alignPast [def,null] let [_,_,p1,_,p2,_,p3] = scanl mappend (start thisInstr) 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 = oppFlags $ fi $ if r>=16 then r-16 else 0x4+ testCode = oppFlags $ fi $ case r of Flags f -> f ; _ -> 0x4 mapM_ tell codes alts@(def:rest) -> readFuture $ do ([Left r],c) <- listen $ unReadFuture $ loadArgs [(v,Nothing)]@@ -454,20 +275,21 @@ mapM_ tell codes compile' (Bind bv arg) = do- future $ modifyF fregistersF $ \rs -> foldr BM.delete rs (bindSyms bv)- when (isNothing arg) $ modifyF frameF (frameAlloc defSize bv)--compile' Noop = withFuture (align . fregisters)- where align regs = void $ withFreeSet $ loadArgs [(SymVal Value s,Just r) | (s,r) <- BM.toList regs]+ future $ viewing flocations_ $ sequence_ [modify (R.setRan s S.empty) | s <- bindSyms bv]+ viewing locations_ $ sequence_ [modify (R.insert s Memory) | s <- bindSyms bv]+ when (isNothing arg) $ modifying frame_ (frameAlloc defSize bv)+ +compile' Noop = withFuture (align . flocations)+ where align regs = void $ withFreeSet $ loadArgs [(SymVal Value s,Just r) | (s,Register r) <- R.toList regs] compileOp BCall d (fun:args) = withFreeSet $ do- let (MemState regs _ subFrame,_) = defaults [BindVar id (sz,0) 0 []- | (id,arg) <- argAssocs- | sz <- map argSize args] undefined+ let (MemState locs subFrame,_) = defaults [BindVar id (sz,0) 0 []+ | (id,arg) <- argAssocs+ | sz <- map argSize args] undefined argAssocs = zip (map ID [0..]) args storeBig top (id,arg) = case lookupAddr id subFrame of Just addr -> case argVal arg of- Left s -> do+ Left (_,s) -> do let loadAddr (r,n) = do a <- stackAddr defSize r ; ld rdi (rsp,fi a,defSize) ; return (rdi,n) (base,n) <- maybe ((rsp,) $< stackAddr size s) loadAddr $ binding s let addrs = [0,defSize..size]@@ -480,12 +302,12 @@ Nothing -> return () modify (SB.delete rax)- let args' = [(arg,r :: Maybe Register) | (id,arg) <- argAssocs, let r = BM.lookup id regs, isJust r]+ let args' = [(arg,Just r) | (id,arg) <- argAssocs, Register r <- symLocs id locs] (func:_,cload) <- listen $ loadArgs $ (fun,Nothing):args' readFuture $ do put (SB.empty compare)- (_,cstore) <- listen $ storeRegs allocRegs+ (_,cstore) <- listen $ saveRegs allocRegs top <- lift $ gets (frameTop . frame) (_,cstore') <- listen $ do lift $ mapM_ (storeBig top) argAssocs@@ -494,20 +316,22 @@ BC ~(_,delta,_) = cload <> cstore <> cstore' (call <|||> calli pos) func addri rsp rsp $ withSize top- lift $ associate rax (Just d)+ lift $ associateVR d rax compileOp b d [s] | b`elem`[BSet,BSetSX,BNot,BSub] && varSize d<=defSize = withFreeSet $ do [v] <- loadArgs [(s,Nothing)] readFuture $ do- let dest r = maybe (destRegister d) (const $ return r) $ mfilter (not . isActive) $ argValSym s+ let dest r = maybe (destRegister d) (const $ return r) $ mfilter (not . isActive) $ valSym s r' <- dest $ (id ||| const 0) v (mov r' <|||> movi r') v- when (argSize s < varSize d) $ case b of- BSet -> zxtnd r' (argSize s)- BSetSX -> sxtnd r' (argSize s)+ when (argSize s < varSize d) $ case () of+ () | b`elem`[BSet,BNot] -> zxtnd r' (argSize s)+ | b`elem`[BSetSX,BSub] -> sxtnd r' (argSize s)+ case b of BNot -> notr r' BSub -> negr r'- lift $ associate r' (Just d)+ _ -> doNothing+ lift $ associateVar d (S.singleton (Register r')) compileOp b d [a,a'] | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do let ops = fromJust $ lookup b [(BAdd,(addrr,addri,addir,(+)))@@ -520,27 +344,26 @@ readFuture $ do dest <- destRegister d opsCode ops dest v v'- lift $ associate dest (Just d)+ lift $ associateVR d dest | b`elem`[BLowerThan,BLowerEq,BEqual,BNotEqual,BGreaterEq,BGreaterThan] = withFreeSet $ do- let dest = 16 + fromJust (lookup b codes)+ let flag = fromJust (lookup b codes) codes = [(BLowerThan,0xc),(BLowerEq,0xe),(BGreaterEq,0xf),(BGreaterThan,0xd),(BEqual,0x4),(BNotEqual,0x5)] applys = [(BLowerThan,(<)),(BLowerEq,(<=)),(BGreaterEq,(>=)),(BGreaterThan,(>)),(BEqual,(==)),(BNotEqual,(/=))] convert f n n' = if f n n' then 1 else 0 [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)] readFuture $ do- opsCode (cmprr,cmpri,cmpir,convert $ fromJust (lookup b applys)) dest v v'- lift $ associate dest (Just d)+ opsCode (cmprr,cmpri,cmpir,convert $ fromJust (lookup b applys)) flag v v'+ lift $ associateVL d (Flags flag) | b`elem`[BMod,BDiv] = withFreeSet $ do [_,_,v] <- loadArgs [(a,Just rax),(IntVal 0,Just rdx),(a',Nothing)] readFuture $ do- case mfilter (/=d) $ argValSym a of- Just s | isActive s -> storeRegs [rax]+ case mfilter (/=d) $ valSym a of+ Just s | isActive s -> saveRegs [rax] _ -> return () case v of Left r -> op [0xf7] 7 7 r Right v -> opi (codeFun []) [0xf7] 7 7 v- lift $ associate (if b==BMod then rdx else rax) (Just d)-+ lift $ associateVR d (if b==BMod then rdx else rax) compileOp b d args@(a:a':t) | isBinOp b = sequence_ [compileOp b d [a,a'] | b <- repeat b
+ src/Specialize/X86_64/Binary.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE NoMonomorphismRestriction, ViewPatterns #-}+module Specialize.X86_64.Binary where++import Control.Monad.Writer+import Data.Bits+import Data.Maybe+import Data.Ord+import Data.Word+import My.Data.List+import PCode.Instruction+import Specialize.Types+import qualified Data.ByteString as B++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))] -> (Int,IO Integer) -> Maybe (Word8,Int,Int,IO [Word8])++fi = fromIntegral ; fis = fmap fromIntegral++defSize = 8+registers@[rax,rcx,rdx,rbx,rsp,rbp,rsi,rdi,r8,r9,r10,r11,r12,r13,r14,r15] = [0..15] :: [Int]++(execStub,initStub, callStub0, callStub1) = (writerStub exec,writerStub init,+ writerStub . callStub0,writerStub . callStub1)+ where cStub loadArgs = do+ mapM_ push saved+ loadArgs+ call rdi+ mapM_ pop saved+ tellCode [0xc3]+ alphaStub loadArgs f = do+ loadArgs+ movi rsi (withSize (f :: Integer))+ call rsi+ tellCode [0xc3]+ saved = rbx:rbp:[r12..r15]+ init = cStub (mov rdx rsi)+ exec = cStub (return ())+ callStub0 = alphaStub (return ())+ callStub1 = alphaStub (mov rdi rdx)+ push r = tellCode $ pre++[0x50.|.(fi r.&.7)]+ where (pre,_) = argBytesWide False 0 r Nothing+ pop r = tellCode $ pre++[0x58.|.(fi r.&.7)]+ where (pre,_) = argBytesWide False 0 r Nothing+ writerStub stub = let BC (_,_,code) = execWriter stub in code++bSize (bindSize -> (n,nr)) = n+nr*defSize+numSize n | n>=0 = numSize 64 n+ | otherwise = 1+numSize 64 (-1-n)+ where numSize 0 _ = 1+ numSize bl n = case reverse $ takeWhile (>0) $ iterate (`shiftR`bl) n of+ [] -> 0+ (x:t) -> (length t)*bl + numSize (bl`div`2) x+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)++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 = (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 ++ 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,[n])+ | otherwise = (2,take 4 $ bytes n)+ sib | mode/=3 && (rm.&.7 == 4) = [fromFields [(4,3),(4,3),(0,2)]]+ | otherwise = []++op code d a b | d==b = op d a+ | otherwise = mov d a >> op d b+ where op d a = tellCode $ pre++code++suf+ where (pre,suf) = argBytes d a Nothing+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 rsi n >> op def d a rsi+codeFun codes (size,n) = listToMaybe [(code,r,count,imm count) | (s,(code,count,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,_) = bwxorrr d d d+movi d n = tell $ fromBytesN (length pref+s) (liftM (pref++) imm)+ where (code,r,s,imm) = fromJust $ codeFun [(31,(0xC7,4,0)),(64,(0xB8`xor`(fi d.&.7),8,0))] n+ (pre,suf) | code==0xC7 = argBytes 0 d Nothing+ | 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)+zxtnd r s = case (s :: Int) of+ 1 -> tellCode (pre++[0x0f,0xb6]++post)+ 2 -> tellCode (pre++[0x0f,0xb7]++post)+ _ -> shli r r sz >> shri r r sz+ where sz = withSize $ 8*(defSize-s)+ where (pre,post) = argBytes r r Nothing+sxtnd r s = case (s :: Int) of+ 1 -> tellCode (pre++[0x0f,0xbe]++post)+ 2 -> tellCode (pre++[0x0f,0xbf]++post)+ 4 -> tellCode (pre++[0x63]++post)+ _ -> shli r r sz >> sari r r sz+ where sz = withSize $ 8*(defSize-s)+ where (pre,post) = argBytes r r Nothing+ +setcc r f = tellCode (pre++[0x0f,0x90.|.fi f]++post) >> zxtnd r 1+ where (pre,post) = argBytesWide False 0 r Nothing++shli = opi (codeFun [(8,(0xC1,1,4))]) undefined+shri = opi (codeFun [(8,(0xC1,1,5))]) undefined+sari = opi (codeFun [(8,(0xC1,1,7))]) undefined+rori d s n | n==0||n==64 = return ()+ | otherwise = opi (codeFun [(8,(0xC1,1,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 = sequence_ $ zipWith ldChunk (reverse $ zip (sums szs) szs) (True:repeat False)+ ldChunk (i,sz) fst = sh sz >> tellCode (pre'++pre++code++suf)+ where (pre,suf) = argBytesWide (sz==8) d s (Just (n+i))+ (pre',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 = sequence_ $ reverse [stChunk a b | (a,b) <- zip (reverse $ zip (sums szs) szs) (True:repeat False)]+ stChunk (i,sz) lst = tellCode (pre'++pre++code++suf) >> sh sz+ where (pre,suf) = argBytesWide (sz==8) s d (Just (n+i))+ (pre',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)++commOp c c' = (op c,opn,flip . opn)+ where opn = opi (codeFun c') c++addri d r (0,_) = return ()+addri d r v = addri' d r v+(addrr,addri',addir) = commOp [0x03] [(8,(0x83,1,0)),(32,(0x81,4,0))]+(mulrr,mulri,mulir) = commOp [0x0F,0xAF] [(8,(0x6B,1,0)),(64,(0x69,8,0))]+(bwandrr,bwandri,bwandir) = commOp [0x23] [(7,(0x83,1,4)),(31,(0x81,4,4))]+(bworrr,bworri,bworir) = commOp [0x0b] [(7,(0x83,1,1)),(31,(0x81,4,1))]+(bwxorrr,bwxorri,bwxorir) = commOp [0x33] [(7,(0x83,1,6)),(31,(0x81,4,6))]+notr r = tellCode $ pre++[0xf7]++post+ where (pre,post) = argBytes 2 r Nothing+negr r = tellCode $ pre++[0xf7]++post+ where (pre,post) = argBytes 3 r Nothing+subrr d a b | d==b = op [0x2b] d d a >> negr d+ | otherwise = op [0x2b] d a b+subri d r (0,_) = return ()+subri d r v = opi (codeFun [(8,(0x83,1,5)),(32,(0x81,4,5))]) [0x2b] d r v+subir d n a | d==a = subri d d n >> negr d+ | otherwise = movi d n >> subrr d d a++cmprr _ a b = op [0x3b] a a b+cmpri _ a = opi (codeFun codes) [0x3b] a a+ where codes = [(8,(0x83,1,7)),(32,(0x81,4,7))]+cmpir _ n a = movi rsi n >> cmprr rsi rsi a++calli pos (size,v) = tell $ fromBytesN 5 $ do+ pos <- pos ; v <- v+ -- putStrLn $ "calli: size="++show size++" pos="++show pos++" dest="++show v+ return $ [0xe8]++take 4 (bytes (v-fi pos-5))+call r = tellCode $ pre++[0xff]++post+ where (pre,post) = argBytesWide False 2 r Nothing++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 (min s s',liftM2 ii n n')+