alpha 0.99 → 0.995
raw patch · 12 files changed
+318/−186 lines, 12 files
Files
- alpha.cabal +1/−1
- src/Alpha.hs +1/−1
- src/Compile.hs +1/−1
- src/Compile/Utils.hs +20/−16
- src/Context.hs +55/−19
- src/My/Prelude.hs +12/−0
- src/PCode/Builtin.hs +3/−2
- src/PCode/Instruction.hs +1/−0
- src/Specialize.hs +13/−10
- src/Specialize/Architecture.hs +3/−1
- src/Specialize/Types.hs +20/−8
- src/Specialize/X86_64.hs +188/−127
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 0.99+version: 0.995 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
src/Alpha.hs view
@@ -36,7 +36,7 @@ PrintVersion -> printVersion Compile -> doCompile s -version = "0.99"+version = "0.995" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version
src/Compile.hs view
@@ -18,7 +18,7 @@ compile dest expr = runStateT st defaultState >§ \(code,cs) -> (code,imports cs) where st = do (_,(start,_)) <- compile' dest expr- simplify start >>= linearize >>= lift . uniquify+ simplify start >>= linearize -- >>= lift . uniquify compile' dest (Symbol sym) = do name <- getSymName sym
src/Compile/Utils.hs view
@@ -11,6 +11,7 @@ import qualified Data.Map as M import qualified Data.Set as S+import Data.Function import Data.Maybe import PCode import Syntax @@ -35,7 +36,7 @@ return $ concatMap (newStart oldDep newDep) start where purgeAll = do- mapM_ (purgeNode isNoop) =<< getNodeList + mapM_ (purgeNode isNoop) =<< getNodeList mapM_ (purgeNode isEmptyBranch) =<< getNodeList purgeNode p n = do c <- getContext n @@ -55,17 +56,15 @@ mergeEdge (BranchAlt t x) (BranchAlt t' _) = BranchAlt (least t t') x mergeEdge TimeDep b = b mergeEdge e t = mergeEdge t e- sequence_ [createEdge (mergeEdge t t') n n'' | (n ,t) <- lies, (n'',t') <- loes ] sequence_ [deleteEdge n n' | (n ,_) <- lies ] sequence_ [deleteEdge n' n'' | (n'',_) <- loes ]+ sequence_ [createEdge (mergeEdge t t') n n'' | (n ,t) <- lies, (n'',t') <- loes ] deleteNode n' newStart old new = newStart where - newStart n = - maybe (maybe [] (\c -> concat [newStart n | (n,_) <- outEdges c])- (lookupContext n old)) - (const [n])- (lookupContext n new)+ newStart n = fromJust $ (lookupContext n new >> return [n])+ `mplus` (lookupContext n old >§ \c -> concat [newStart n | (n,_) <- outEdges c])+ `mplus` return [] data ANode = ANode { weight :: Int,@@ -79,16 +78,18 @@ aG = annotate depG getContext n = G.getContext n aG withContext n = (n,getContext n)+ (<#) = ((<) `on` (weight . tag)) isBrPart (instr . tag . getContext -> BrPart _) = True isBrPart _ = False- instrMap = M.fromList [(n,i) | (i,(n,_)) <- zip [0..] $ concat [map (n,) (getInstr n) | n <- concat blocks]]+ instrMap = M.fromList $ zip instrs (sums (map (length . getInstr) instrs))+ where instrs = concat blocks instrs = concatMap (concatMap getInstr) blocks getInstr (getContext -> c) = case tag c of ANode { instr = BrPart v } -> [Branch v $ map branch (classesBy (===) oes)] where branch ns = minimum $ catMaybes [M.lookup n instrMap | (n,_) <- ns]- (_,e) === (_,e') = e==e'+ (===) = (==)`on`snd ANode { instr = Instr i } -> i : if null oes then [ret] else [] where oes = outEdges c @@ -97,14 +98,17 @@ heads = startHeads : deleteBy headsEq startHeads heads where eq n1 n2 = if n1`elem`start then n2`elem`start else c' where c' = n2 `elem` [n | (n,e') <- outEdges $ getContext prev, e==e']- (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG) $ find isBackEdge $ inEdges $ getContext n1+ (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG)+ $ find isBackEdge $ inEdges $ getContext n1 headsEq a b = sort a==sort b heads = classesBy eq $ selectHeads $ nodeListFull aG- tails = map (nub . concatMap saturate) heads+ tails = map (S.toList . S.unions) $ classesBy share $ map (S.fromList . concatMap saturate) heads+ where share s s' = not $ S.null (s `S.intersection` s') saturate n = if null nexts then [n] else concatMap saturate nexts where nexts = [n' | let c = getContext n , (n',c') <- map withContext $ nextNodes c- , weight (tag c') > weight (tag c)]+ , c <# c']+ blocks = map blockFromTails tails blockFromTails tails = evalState (concat $< mapM makeBlock tails) S.empty@@ -115,10 +119,10 @@ prevs <- mapM makeBlock (getPrevs n) visit n return $ concat prevs ++ [n]- getPrevs n = map fst $ sortBy cmp $ filter p $ map withContext $ prevNodes language- where cmp (_,c) (_,c') = compare (erNum $ tag c') (erNum $ tag c)- p (_,c) = weight (tag c) < weight (tag language)- language = getContext n+ getPrevs n = map fst $ sortBy cmp $ filter p $ map withContext $ prevNodes ctx+ where cmp = compare `on` (erNum . tag . snd)+ p (_,c) = c <# ctx+ ctx = getContext n annotate depG = newdepG where
src/Context.hs view
@@ -6,12 +6,14 @@ ,doTransform ,getAddressComp ,execCode) where +import Bindings.Posix.Unistd import Bindings.Posix.Sys.Mman import Context.Language as Lang import Context.Language import Context.Types-import Data.ByteString+import Data.ByteString hiding (map,putStrLn) import Data.ByteString.Unsafe+import Data.ByteString.Internal import Data.Functor.Identity import Data.IORef import Data.Maybe@@ -39,11 +41,37 @@ get = readIORef contextRef put = writeIORef contextRef -addressRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int)+funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f++exportAlpha stub ptr = unsafePerformIO $ do+ unsafeUseAsCStringLen (stub $ funPtrToInteger ptr) $ \(src,size) -> do+ ptr <- mallocForeignPtrBytes size+ withForeignPtr ptr $ \dst -> copyBytes (castPtr dst) src size+ return ptr+ foreign export ccall "address_" address_ :: ID -> IO Int-address_ i = readIORef addressRef >>= ($i) foreign import ccall "&address_" address_ptr :: FunPtr (ID -> IO Int)+addressRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int)+address_ id = readIORef addressRef >>= ($id) +foreign export ccall "symName_" symName_ :: ID -> IO (Ptr Word8)+foreign import ccall "&symName_" symName_ptr :: FunPtr (ID -> IO (Ptr Word8))+symName_ sym = do+ n <- gets (lookupSymName sym . language)+ ret <- newArray0 0 (map c2w $ fromMaybe "" n)+ return ret++foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ())+foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ()))+allocate_ = mallocBytes++foreign export ccall "printOK_" printOK_ :: IO ()+foreign import ccall "&printOK_" printOK_ptr :: FunPtr (IO ())+printOK_ = Prelude.putStrLn "OK"+foreign export ccall "printNum_" printNum_ :: Int -> IO ()+foreign import ccall "&printNum_" printNum_ptr :: FunPtr (Int -> IO ())+printNum_ n = print (intPtrToPtr $ fromIntegral n)+ initialBindings = [(n,Left $ Builtin b) | (b,n) <- bNames] ++ [ ("alter" ,Left $ Axiom XAlter), ("bind" ,Left $ Axiom XBind),@@ -60,7 +88,11 @@ ("id" ,Left $ Axiom XID), ("@" ,Left $ Axiom XAddr), ("#" ,Left $ Axiom XSize)] ++ [- ("addressC",Right $ castFunPtrToPtr address_ptr)+ ("alpha/c@" , Right $ exportAlpha callStub1 address_ptr), + ("alpha/symbol-name" , Right $ exportAlpha callStub1 symName_ptr), + ("alpha/allocate" , Right $ exportAlpha callStub1 allocate_ptr), + ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), + ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr) ] doTransform syn = gets transform >>= ($syn)@@ -71,7 +103,7 @@ i <- stateF fstF (internSym s) case v of Left v -> modifyF fstF (setSymVal i v)- Right p -> modifyF sndF (M.insert i $ unsafePerformIO $ newForeignPtr_ p)+ Right p -> modifyF sndF (M.insert i p) withDefaultContext = withState initialContext @@ -82,34 +114,38 @@ foreign import ccall "dynamic" mkFunSize :: FunPtr (Ptr() -> IO Int) -> Ptr() -> IO Int foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO () +pageSize = fromIntegral $ unsafePerformIO $ c'sysconf c'_SC_PAGESIZE+enableExec p size = do+ let p' = alignPtr (p`plusPtr`(1-pageSize)) pageSize+ mprotect (castPtr p') (fromIntegral $ size+ p`minusPtr`p') (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC)+ getAddress arch lookup register = withRef addressRef getAddr . getAddr where- getAddr id = lookup id >>= \val -> case val of+ getAddr sym = lookup sym >>= \val -> case val of Just a -> return a- Nothing -> gets language >>= \lang -> (>> getAddr id) $ case lookupSymVal id lang of+ Nothing -> gets language >>= \lang -> (>> getAddr sym) $ case lookupSymVal sym lang of Verb c -> void $ do- let (size,codem) = specialize arch (id,getAddr) c+ let (size,codem) = specialize arch (sym,getAddr) c ptr <- mallocForeignPtrBytes size- register id ptr size+ register sym ptr size code <- codem withForeignPtr ptr $ \p -> do unsafeUseAsCStringLen code $ \(p',n) -> copyBytes p (castPtr p') n- mprotect (castPtr p) (fromIntegral size) (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC)+ enableExec p size Noun size init -> do- size <- join $ evalCode mkFunSize execStub size+ size <- evalCode mkFunSize execStub size id ptr <- mallocForeignPtrBytes size- register id ptr size- withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init >>= ($castPtr p)- _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show id) (lookupSymName id lang)+ register sym ptr size+ withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init ($castPtr p)+ _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show sym) (lookupSymName sym lang) -evalCode :: (FunPtr (Ptr() -> a) -> (Ptr() -> a)) -> ByteString -> Code -> IO a-evalCode wrap stub code = do+evalCode :: (FunPtr (Ptr() -> a) -> Ptr() -> a) -> ByteString -> Code -> (a -> IO b) -> IO b+evalCode wrap stub code f = do id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i p <- getAddressJIT id- unsafeUseAsCString stub $ \stub ->- return $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) + unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) execCode [] = return ()-execCode instrs = join $ evalCode mkProc execStub (Code [] instrs (symBind (ID (-1))))+execCode instrs = evalCode mkProc execStub (Code [] instrs (symBind (ID (-1)))) id getAddressJIT = getAddress hostArch lookup register where lookup id = do
src/My/Prelude.hs view
@@ -5,6 +5,11 @@ import Data.Maybe import Debug.Trace as Tr import My.Control.Monad+import qualified Data.ByteString as B+import Data.List+import Data.Char+import Data.Word+import Data.Array debugMess mess x = Tr.trace (mess++show x) x debug x = traceShow x x@@ -23,4 +28,11 @@ newerThan f1 f2 = liftM2 (>) (modTime f1) (modTime f2) where modTime f = modificationTime $< getFileStatus f++showHex n = reverse $ map (intToDigit . fromIntegral . (`mod`16)) $ take 2 $ iterate (`div`16) (n :: Word8)+showCode code = intercalate " " $ map showHex $ B.unpack $ code++a !# i | bounds a`inRange`i = a!i+ | otherwise = error $ "undefined index "++show i++" in array "+
src/PCode/Builtin.hs view
@@ -5,7 +5,7 @@ | BLowerEq | BLowerThan | BGreaterEq | BGreaterThan | BEqual | BNotEqual | BCall- | BSet+ | BSet | BSetSX deriving (Show,Eq) isBinOp b = b/=BCall && b/=BSet && b/=BNot@@ -13,5 +13,6 @@ bNames = [(BAdd,"+"),(BMul,"*"),(BSub,"-"),(BDiv,"/"),(BMod,"%"), (BLowerThan,"<"),(BGreaterThan,">"),(BLowerEq,"<="),(BGreaterEq,">="), (BEqual,"=="),(BNotEqual,"<>"),- (BAnd,"&"),(BOr,"|"),(BXor,"x|"),(BNot,"not")]+ (BAnd,"&"),(BOr,"|"),(BXor,"x|"),(BNot,"not"),+ (BSet,"^"),(BSetSX,"¨")]
src/PCode/Instruction.hs view
@@ -10,6 +10,7 @@ import PCode.Builtin import PCode.Value import ID+import My.Prelude type Addr = Int data BindVar = BindVar {
src/Specialize.hs view
@@ -55,11 +55,11 @@ nextFuture i f = snd4 $ runInstr i undefined f (const Nothing) gens = array bounds $ zip (flatten codeTree) [0..] gens' = array bounds $ zip [0..] (flatten codeTree)- getPast g i | g >= gens!i = Just $ fst $ instrs!i+ getPast g i | g >= gens!i = Just $ fst $ instrs!#i | otherwise = Nothing instrs = array bounds $ flatten $ descend desc past codeTree where desc i p = ((i,(p,c)),p')- where ~(p',_,_,c) = runInstr i p (snd $ futures!g!i) (getPast g)+ where ~(p',_,_,c) = runInstr i p (snd $ futures!g!#i) (getPast g) g = gens!i futures = fmap snd $ listArray bounds $ iterate nextFut (1,initial) where initial = execState (sequence_ [changeFuture i 0 (futureOf i) | i <- map last (branches codeTree)])@@ -68,7 +68,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 $ registers $ fst (instrs!#instr) changeFuture i g f = puti i (g,f) >> mapM_ propagate (prevs i) propagate i = do let j = head (nexts i)@@ -92,9 +92,9 @@ fun i a = (addActives (instr i) out,out) where out = S.unions (map ((a!) >>> fst) (nexts i)) addActives (Op _ v vs) s = (s S.\\ clobbers i v)- <> S.unions [clobbers i s' | SymVal Value s <- vs- , s' <- s:maybeToList (root i s)]- <> S.fromList (catMaybes [root i s | SymVal Address s <- SymVal Address v:vs])+ <> S.unions [clobbers i s | SymVal Value s <- vs]+ <> S.fromList (catMaybes [root i s | SymVal t s <- SymVal Address v:vs+ , t==Value || t==Address]) addActives (Branch (SymVal Value id) _) s = s <> clobbers i id addActives (Bind _ v) s = maybe id S.insert v s addActives _ s = s@@ -107,11 +107,14 @@ where next i r (Bind bv v) = insertManyA r assocs where assocs = [(bindSym bv,s) | bv <- bindNodes bv , s <- bindSyms bv]- ++[(s,ref) | v <- maybeToList v- , ref <- S.toList $ references i v- , s <- maybe [v] S.toList (R.lookupRan ref r)]+ ++[(s,s') | v <- maybeToList v+ , ref <- S.toList $ references i v+ , s <- S.toList $ clobbers i ref+ , s' <- bindSyms bv] next i r (Op BCall d (_:args)) = insertManyA r assocs- where assocs = map (worldID,) $ d : argRefs i args+ where assocs = [a | ref <- d : argRefs i args+ , v <- S.toList $ clobbers i ref+ , 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
src/Specialize/Architecture.hs view
@@ -2,7 +2,7 @@ ,arch_x86 ,arch_x86_64 ,arch_arm- ,hostArch,Specialize.Architecture.execStub,Specialize.Architecture.initStub+ ,hostArch,Specialize.Architecture.execStub,Specialize.Architecture.initStub,Specialize.Architecture.callStub0,Specialize.Architecture.callStub1 ,architectures) where import Specialize.Types@@ -25,3 +25,5 @@ execStub = unsafePerformIO Host.execStub initStub = unsafePerformIO Host.initStub+callStub0 = unsafePerformIO . Host.callStub0+callStub1 = unsafePerformIO . Host.callStub1
src/Specialize/Types.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE RankNTypes #-} module Specialize.Types(module Data.Word, module My.Control.Monad.RWTL ,module PCode, module ID,module Specialize.Frame- ,Register(..),BinCode(..), isEmptyCode+ ,Register(..),BinCode(..), isEmptyCode, binCodeData ,Architecture(..) ,Info(..) ,MemState(..),Future(..), emptyFuture- ,frameF, registersF, fregistersF) where+ ,frameF, registersF, changedF, fregistersF) where import Data.Bimap+import Data.Set import Data.ByteString import Data.Map import Data.Relation@@ -24,9 +25,10 @@ mempty = BC (0,0,return mempty) mappend (BC ~(e,s,v)) (BC ~(e',s',v')) = BC (e+e',s+s',liftM2 (<>) v v') instance Show BinCode where- show (BC (e,a,_)) = show (e,a)+ show (BC (e,s,_)) = show (e,s) isEmptyCode (BC (e,_,_)) = e==0+binCodeData (BC (_,_,b)) = b type Register = Int data Architecture = Arch {@@ -36,8 +38,9 @@ archCompileInstr :: Instruction -> RWTL Info BinCode MemState Future () } data MemState = MemState {- registers :: Bimap ID Register,- frame :: Frame+ registers :: Bimap ID Register,+ changed :: Set ID,+ frame :: Frame } deriving Show data Future = Future {@@ -54,8 +57,17 @@ branchPos :: (Int,Int -> (Int,Int,Maybe MemState)) } -frameF = Field (frame,\f p -> p { frame = f })-registersF = Field (registers,\r p -> p { registers = r })-fregistersF = Field (fregisters,\r f -> f { fregisters = r })+instance Show Info where+ show (Info _ b sz a c l _) = "Info { bindings = "++show b+ ++", sizes = "++show sz+ ++", actives = "++show a+ ++", clobbers = "++show c+ ++", locals = "++show l+ ++" }"++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 }) emptyFuture = Future Data.Bimap.empty
src/Specialize/X86_64.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE ViewPatterns, TupleSections, ParallelListComp, ImplicitParams, NoMonomorphismRestriction, Rank2Types #-}-module Specialize.X86_64(arch_x86_64,execStub,initStub) where+{-# LANGUAGE ViewPatterns, TupleSections, ParallelListComp, ImplicitParams, NoMonomorphismRestriction #-}+module Specialize.X86_64(arch_x86_64,execStub,initStub,callStub0,callStub1) where import Control.Monad.Writer.Class @@ -30,24 +30,27 @@ bytes :: (Bits a,Integral a,Num b) => a -> [b] defSize :: Num a => a argBytesWide :: Bool -> Int -> Int -> (Maybe Integer) -> ([Word8],[Word8])-codeFun :: [(Int,(Word8,Int))] -> (Int,IO Integer) -> Maybe (Word8,Int,Int,IO [Word8])--type OpT = MonadWriter BinCode m => (Int -> Int -> Int -> m ()- ,Int -> Int -> (Int,IO Integer) -> m ()- ,Int -> (Int,IO Integer) -> Int -> m ()- ,Integer -> Integer -> Integer)+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) = (writerStub exec,writerStub init)- where callStub loadArgs = do+(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 = callStub (mov rdx rsi)- exec = callStub (return ())+ 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)]@@ -56,19 +59,24 @@ defSize = 8 ([rax,rcx,rdx,rbx,rsp,rbp,rsi,rdi,r8,r9,r10,r11,r12,r13,r14,r15],allocRegs) =- (regs,filter (not . (`elem`[rsp,r15])) regs)+ (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) -showHex n = reverse $ map (intToDigit . fromIntegral . (`mod`16)) $ take 2 $ iterate (`div`16) (n :: Word8)-showCode = intercalate " " . map showHex- bSize (bindSize -> (n,nr)) = n+nr*defSize-numSize n = length $ takeWhile (>0) $ iterate (`shiftR`8) n+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)@@ -97,26 +105,43 @@ Just (code,r,s',imm) -> mov d a >> tell (fromBytesN (length pref+s') (liftM (pref++) imm)) where (pre,suf) = argBytes r d Nothing pref = pre++[code]++suf- Nothing -> movi r15 n >> op def d a r15-codeFun codes (size,n) = listToMaybe [(code,r,s,imm s) | (s,(code,r)) <- codes, s>=size]+ 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+ | otherwise = tellCode (pre++[0x8b]++suf) where (pre,suf) = argBytes d s Nothing-movi d (0,_) = bwxor d d d+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 [(4,(0xC7,0)),(8,(0xB8`xor`(fi d.&.7),0))] n+ 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 [(1,(0xC1,4))]) undefined-shri = opi (codeFun [(1,(0xC1,5))]) undefined+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 [(1,(0xC1,1))]) undefined d s (withSize n)+ | 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]@@ -124,11 +149,7 @@ 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 = do- sh sz- if sz==1 && d>=4 && d<8- then (if fst then return () else mov r15 d) >> ld r15 (s,n+i,1) >> mov d r15- else tellCode $ pre'++pre++code++suf+ 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]))@@ -143,11 +164,7 @@ 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 = do- (if sz==1 && d>=4 && d<8- then mov r15 s >> st (d,n+i,1) r15- else tellCode $ pre'++pre++code++suf)- sh sz+ 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]))@@ -156,30 +173,34 @@ sh sz | lst = rori s s ((8-i)*8) | otherwise = rori s s (sz*8) -commOp c c' f = (op c,opn,flip . opn,f :: Integer -> Integer -> Integer)+commOp c c' = (op c,opn,flip . opn) where opn = opi (codeFun c') c -adds@(add,addi,_,_) = commOp [0x03] [(1,(0x83,0)),(4,(0x81,0))] (+)-muls@(mul,muli,_,_) = commOp [0x0F,0xAF] [(1,(0x6B,0)),(8,(0x69,0))] (*)-bwands@(bwand,bwandi,_,_) = commOp [0x23] [(1,(0x83,4)),(4,(0x81,4))] (.&.)-bwors@(bwor,bwori,_,_) = commOp [0x0b] [(1,(0x83,1)),(4,(0x81,1))] (.|.)-bwxors@(bwxor,bwxori,_,_) = commOp [0x33] [(1,(0x83,6)),(4,(0x81,6))] xor-subs :: OpT-subs@(sub,subi,_,_) = (sub,opi (codeFun codes) [0x2b],subi',(-))- where neg r = tellCode $ pre++[0xf7]++post- where (pre,post) = argBytes 3 r Nothing- sub d a b | d==b = op [0x2b] d d a >> neg d- | otherwise = op [0x2b] d a b- codes = [(1,(0x83,5)),(4,(0x81,5))]- subi' d n a | d==a = subi d d n >> neg d- | otherwise = movi d n >> sub d d a-cmps f = (cmp,cmpi,cmp',f)- where cmp _ a b = op [0x3b] a a b- codes = [(1,(0x83,7)),(4,(0x81,7))]- cmpi _ a = opi (codeFun codes) [0x3b] a a- cmp' _ n a = movi r15 n >> cmp r15 r15 a+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 -calli pos (_,v) = tell $ fromBytesN 5 (liftM2 (\p v -> [0xe8]++take 4 (bytes (v-fi p-5))) pos v)+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 @@ -189,19 +210,10 @@ (Right v,Left r) -> ir dest v r (Right (s,n),Right (s',n')) -> movi dest (max s s',liftM2 ii n n') -associate r (Just s) = modifyF registersF $ BM.insert s r-associate r Nothing = modifyF registersF $ BM.deleteR r-frameAddr s = stateF frameF (withAddr defSize s) >§ \n -> (-8)-n-lookupSymIn = flip BM.lookupR-lookupRegIn = flip BM.lookup-argValSym (SymVal Value s) = Just s-argValSym _ = Nothing-lookupArgReg arg m = argValSym arg >>= lookupRegIn m- argVal (IntVal n) = Right $ withSize n argVal (SymVal Size s) = Right $ withSize $ fromMaybe defSize $ M.lookup s (sizes ?info) argVal (SymVal SymID (ID s)) = Right $ withSize $ s-argVal (SymVal _ s) = maybe (Left s) (Right . (4,)) $ globVal s+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)@@ -209,7 +221,21 @@ 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@@ -234,7 +260,7 @@ allocReg sym = lift regInfo >>= \(_,regs) -> do let st free = (r,SB.delete r free)- where r | SB.null free = r15+ where r | SB.null free = rdi | otherwise = fromMaybe (SB.findMin free) $ mfilter (`SB.member`free) $ lookupRegIn regs sym state st@@ -242,16 +268,17 @@ 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 find ((==Just d) . findReg) allocRegs `mplus` find (isNothing . findReg) allocRegs of+ 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 s = lookupSymIn regs s `mplus` lookupSymIn fregs s+ 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 (frameAddr s)+ a <- lift (stackAddr defSize s) lift $ associate r (Just s) ld r (rsp,fi a,defSize) return r@@ -262,15 +289,18 @@ parent (_,_,b) = fmap fst b groups = classesBy ((==)`on`parent) vars storeGroup g = do- reg <- loadRoot $ parent $ head g- lift $ mapM_ (store reg) g+ 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 (frameAddr s) (return . snd) b+ 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- lift $ modifyF registersF $ \rs -> foldr BM.delete rs [s | (_,s,_) <- vars] loadArgs args = do let modFRegs regs = foldr ($) regs [maybe (BM.deleteR r) (flip BM.insert r) $ argValSym arg@@ -290,22 +320,21 @@ allocs <- mapM argNew alls let assocs = filter (\(r,arg,_) -> not $ (myWorkIsDone r ||| const False) (argVal arg)) $ lefts [left (,arg,bind arg) all | all <- allocs | (arg,_) <- args]- bind (SymVal _ s) | isLocal s = binding s- bind _ = Nothing+ bind arg = argValSym arg >>= binding groups = classesBy ((==)`on`parent) assocs parent (_,_,b) = fmap fst b- myWorkIsDone r s = lookupRegIn regs s == Just r+ 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 (isJust $ lookupSymIn regs r) (storeRegs [r])+ 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 (frameAddr s) return $ fmap snd b+ 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)@@ -319,7 +348,7 @@ free <- get readFuture $ storeRegs (SB.toList free) -defaults args ret = (MemState pregs frame,Future fr)+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@@ -328,42 +357,65 @@ fr | bSize ret<=defSize = BM.singleton (bindSym ret) retReg | otherwise = BM.empty -compile i = ask >>= \info -> let ?info = info in compile' i- +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- (instr,brInfo) <- asks branchPos- let alignPast (brInfo -> (_,_,p)) = maybe doNothing (preserve . alignWith . registers) p- jmpc short long (BC (e,a,_)) (BC (e',a',_)) = BC (length long+4,length code,return $ B.pack code)- where de = e'-e ; da = a'-a+ 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 da)- | otherwise = long++take 4 (bytes da)+ | 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,_) = brInfo i+ start i = BC (est,pos,undefined) where (est,pos) = instrAddress i case alts of [def,null] -> do- (r,c) <- listen $ readFuture $ 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 -> unReadFuture (loadArgs [(v,Nothing)]) >§ \[Left r] -> 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 instr) codes+ 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 = fi $ r-16+ 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 instr) codes+ let [_,_,p] = scanl mappend (start thisInstr) codes codes = [al,jmp p (start def)] mapM_ tell codes [] -> readFuture $ do@@ -375,58 +427,67 @@ unReadFuture $ alignWith (BM.filter isPresent fregs) tellCode [0xc3] -compile' (Bind bv Nothing) = modifyF frameF (frameAlloc defSize bv)-compile' (Bind bv _) = return ()+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- (instr,brInfo) <- asks branchPos- (myID,addrs) <- asks envInfo- let (MemState regs subFrame,_) = defaults [BindVar id (sz,0) 0 []- | (id,arg) <- argAssocs- | sz <- map argSize args] undefined+ let (MemState regs _ subFrame,_) = defaults [BindVar id (sz,0) 0 []+ | (id,arg) <- argAssocs+ | sz <- map argSize args] undefined argAssocs = zip (map ID [0..]) args- start = BC (est,pos,undefined) where (est,pos,_) = brInfo instr+ 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)- (func:_,cload) <- listen $ loadArgs- $ (fun,Nothing):[(arg,r) | (id,arg) <- argAssocs- , let r = BM.lookup id regs, isJust r]- readFuture $ do- (_,cstore) <- listen $ get >>= \free -> storeRegs (rax:SB.toList free)+ 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)- let storeBig (id,arg) = case lookupAddr id subFrame of- Just addr -> case argVal arg of- Left s -> do- let loadAddr (r,n) = do a <- frameAddr r ; ld r15 (rsp,fi a,defSize) ; return (r15,a)- (base,n) <- maybe ((rsp,) $< frameAddr s) loadAddr $ binding s- let addrs = [0,defSize..sz]- sz = argSize arg- sequence_ [ld rax (base,fi$n+a,fi sz) >> st (rsp,fi $ top+defSize+addr+a,fi sz) rax- | a <- addrs, let sz = min defSize (sz-a)]- Right v -> movi r15 v >> st (rsp,fi $ top+defSize+addr,defSize) rax- Nothing -> return () (_,cstore') <- listen $ do- lift $ mapM_ storeBig argAssocs- subi rsp rsp $ withSize top- let pos = thisFunc >§ (+(instrPos+delta))+ lift $ mapM_ (storeBig top) argAssocs+ subri rsp rsp $ withSize top+ let pos = verbAddress >§ (+(snd (instrAddress thisInstr)+delta)) BC ~(_,delta,_) = cload <> cstore <> cstore'- (_,instrPos,_) = brInfo instr ; thisFunc = addrs myID (call <|||> calli pos) func- addi rsp rsp $ withSize top+ addri rsp rsp $ withSize top lift $ associate rax (Just d) -compileOp BSet d [s] = withFreeSet $ do+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,adds),(BSub,subs),(BMul,muls),(BAnd,bwands),(BOr,bwors),(BXor,bwxors)]+ 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@@ -434,12 +495,12 @@ lift $ associate dest (Just d) | b`elem`[BLowerThan,BLowerEq,BEqual,BNotEqual,BGreaterEq,BGreaterThan] = withFreeSet $ do let dest = 16 + fromJust (lookup b codes)- codes = [(BLowerThan,0xf),(BLowerEq,0xd),(BGreaterEq,0xc),(BGreaterThan,0xe),(BEqual,0x5),(BNotEqual,0x4)]+ 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 (cmps $ convert $ fromJust (lookup b applys)) dest v v'+ 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)]