alpha-0.995: src/Specialize/X86_64.hs
{-# 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
import Control.Monad.Writer
import Data.Bits
import Data.Char
import Data.Function
import Data.Maybe
import Data.Monoid
import Data.Ord
import My.Control.Monad
import My.Control.Monad.State
import My.Data.Either
import My.Data.List
import My.Prelude
import Specialize.Types hiding (call)
import qualified Data.ByteString as B
import qualified Data.Map as M
import qualified Data.Bimap as BM
import qualified Data.Set as S
import qualified My.Data.SetBy as SB
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]
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))]
neg r = tellCode $ pre++[0xf7]++post
where (pre,post) = argBytes 3 r Nothing
subrr d a b | d==b = op [0x2b] d d a >> neg 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 >> neg 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 (max 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 _ s) = maybe (Left s) (Right . (defSize*8,)) $ globVal s
globVal s = if isLocal s then Nothing else Just (toInteger $< snd (envInfo ?info) s)
isLocal s = S.member s (locals ?info)
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
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)
stackAddr sz = liftM (frameToStack sz) . frameAddr
frameToStack sz n = -(n+sz)
lookupSymIn = flip BM.lookupR
lookupRegIn = flip BM.lookup
argValSym (SymVal Value s) | isLocal 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
evalStateT m (SB.fromList cmp allocRegs)
readFuture m = StateT s
where s t = RWTL (\r p f -> let ~(p',_,a,w) = runRWTL (runStateT m t) (r,f) p undef in (p',f,a,w))
undef = error "Illegal use of protected future"
unReadFuture m = StateT s
where s t = RWTL (\(r,f) p _ -> runRWTL (runStateT m t) r p f)
preserve m = StateT s
where s t = RWTL (\r p f -> let (_,_,a,w) = runRWTL (runStateT m t) r p f in (p,f,a,w) )
regInfo = liftM2 (,) (gets registers) (asks (fregisters . snd))
allocReg sym = lift regInfo >>= \(_,regs) -> 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
state st
destRegister d = lift regInfo >>= \(regs,fregs) ->
case mfilter (\r -> maybe True (==d) $ BM.lookupR r regs) $ lookupRegIn fregs d of
Just r -> return r
Nothing -> case mfilter isAllocReg (findSym d) `mplus` find (isNothing . findReg) 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
loadRoot (Just s) = lift regInfo >>= \(regs,_) -> case lookupRegIn regs s of
Just r -> return r
Nothing -> do
r <- allocReg s
a <- lift (stackAddr defSize s)
lift $ associate r (Just s)
ld r (rsp,fi a,defSize)
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]
reg <- if any fst loaded then loadRoot $ parent $ head g else return undefined
lift $ mapM_ (\(c,ge@(r,s,_)) -> when c (store reg ge)
>> associate r Nothing
>> modifyF changedF (S.delete s)) loaded
where store base (r,s,b) = do
n <- maybe (stackAddr (varSize s) s) (return . snd) b
st (base,fi n,fi (varSize s)) r
restrict m = gets (SB.partition isFree) >>= \(free',occ) -> put free' >> m >> modify (SB.union occ)
where isFree = isNothing . lookupSymIn regs
restrict $ mapM_ storeGroup groups
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
readFuture $ do
(regs,_) <- lift regInfo
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)
argAlloc (_,Just r) = return (Left $ Right r)
argNew = leftK (allocReg <|||> return)
modify $ \s -> foldr SB.delete s fixed
alls <- mapM argAlloc args
modify $ \s -> foldr SB.delete s [r | Left (Right r) <- alls]
allocs <- mapM argNew alls
let assocs = filter (\(r,arg,_) -> not $ (myWorkIsDone r ||| const False) (argVal arg))
$ lefts [left (,arg,bind arg) all | all <- allocs | (arg,_) <- args]
bind arg = argValSym arg >>= binding
groups = classesBy ((==)`on`parent) assocs
parent (_,_,b) = fmap fst b
myWorkIsDone r s = BM.pairMember (s,r) regs
loadGroup g = do
base <- loadRoot (parent $ head g)
mapM_ (load base) g
where load base (r,arg,b) = lift regInfo >>= \(regs,_) -> do
when (BM.memberR r regs) (storeRegs [r])
lift $ case argVal arg of
Right v -> movi r v
Left s -> case lookupRegIn regs s of
Just r' -> mov r r'
Nothing -> do
n <- maybe (stackAddr (varSize s) s) return $ fmap snd b
if symValType arg == Value
then ld r (base,fi n,fi (varSize s))
else lea r base (fi n)
lift $ associate r ((Just ||| const Nothing) $ argVal arg)
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)
defaults args ret = (MemState pregs (S.fromList $ map (bindSym . snd) regs) frame,Future fr)
where (regArgs,stArgs) = partition ((<=defSize) . bSize) args
(regs,nonRegs) = zipRest argRegs regArgs
(retReg:funReg:argRegs) = allocRegs
pregs = BM.fromList [(bindSym v,r) | (r,v) <- regs]
frame = foldr (frameAlloc defSize) emptyFrame (stArgs++nonRegs)
fr | bSize ret<=defSize = BM.singleton (bindSym ret) retReg
| otherwise = BM.empty
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
compile i = ask >>= \info -> let ?info = info in
listen (storeFlags (branchSym i)) >>= \(_,BC (e',s',_)) ->
let ?info = info { branchPos = (thisInstr,
\i -> let (e,s,p) = snd (branchPos ?info) i in (e+e',s+s',p)) }
in compile' i
where branchSym (Branch (SymVal Value s) _) = Just s
branchSym _ = Nothing
compile' (Op b d vs) = do
future $ modifyF fregistersF $ BM.delete d
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))
compile' (Branch v alts) = withFreeSet $ do
let alignPast i = maybe doNothing (preserve . alignWith . registers) (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 = []
| de > -128 && de<=128 = short++take 1 (bytes ds)
| otherwise = long++take 4 (bytes ds)
jmp = jmpc [0xeb] [0xe9]
start i = BC (est,pos,undefined) where (est,pos) = instrAddress i
case alts of
[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
Nothing -> do
[Left r] <- unReadFuture (loadArgs [(v,Nothing)])
cmpri r r (withSize (0 :: Int))
return r
[al,al'] <- mapM (listening . 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
mapM_ tell codes
[def] -> do
al <- listening $ alignPast def
let [_,_,p] = scanl mappend (start thisInstr) codes
codes = [al,jmp p (start def)]
mapM_ tell codes
[] -> readFuture $ do
p <- lift get
let isPresent s _ = isJust $ msum [void $ binding s
,void $ lookupAddr s (frame p)
,void $ lookupRegIn (registers p) s]
(_,fregs) <- lift $ regInfo
unReadFuture $ alignWith (BM.filter isPresent fregs)
tellCode [0xc3]
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]
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
argAssocs = zip (map ID [0..]) args
storeBig top (id,arg) = case lookupAddr id subFrame of
Just addr -> case argVal arg of
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]
sequence_ [ld rax (base,fi $ n+a,fi sz)
>> st (rsp,fi $ frameToStack size (top+defSize+addr)+a,fi sz) rax
| a <- addrs, let sz = min defSize (size-a)]
Right v -> movi rdi v >> st (rsp,fi $ frameToStack defSize $ top+defSize+addr,defSize) rdi
where size = argSize arg
Nothing -> return ()
modify (SB.delete rax)
let args' = [(arg,r :: Maybe Register) | (id,arg) <- argAssocs, let r = BM.lookup id regs, isJust r]
(func:_,cload) <- listen $ loadArgs $ (fun,Nothing):args'
readFuture $ do
put (SB.empty compare)
(_,cstore) <- listen $ storeRegs allocRegs
top <- lift $ gets (frameTop . frame)
(_,cstore') <- listen $ do
lift $ mapM_ (storeBig top) argAssocs
subri rsp rsp $ withSize top
let pos = verbAddress >§ (+(snd (instrAddress thisInstr)+delta))
BC ~(_,delta,_) = cload <> cstore <> cstore'
(call <|||> calli pos) func
addri rsp rsp $ withSize top
lift $ associate rax (Just d)
compileOp b d [s] | b`elem`[BSet,BSetSX] && 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
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)
lift $ associate r' (Just d)
compileOp b d [a,a'] | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do
let ops = fromJust $ lookup b [(BAdd,(addrr,addri,addir,(+)))
,(BSub,(subrr,subri,subir,(-)))
,(BMul,(mulrr,mulri,mulir,(*)))
,(BAnd,(bwandrr,bwandri,bwandir,(.&.)))
,(BOr,(bworrr,bworri,bworir,(.|.)))
,(BXor,(bwxorrr,bwxorri,bwxorir,xor))]
[v,v'] <- loadArgs [(a,Nothing),(a',Nothing)]
readFuture $ do
dest <- destRegister d
opsCode ops dest v v'
lift $ associate dest (Just d)
| b`elem`[BLowerThan,BLowerEq,BEqual,BNotEqual,BGreaterEq,BGreaterThan] = withFreeSet $ do
let dest = 16 + 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)
| 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]
_ -> 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)
compileOp b d args@(a:a':t) | isBinOp b =
sequence_ [compileOp b d [a,a']
| b <- repeat b
| d <- repeat d
| a <- a:repeat (SymVal Value d)
| a' <- a':t]
compileOp _ _ _ = return ()