diff --git a/alpha.cabal b/alpha.cabal
--- a/alpha.cabal
+++ b/alpha.cabal
@@ -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
+
 
diff --git a/src/Alpha.hs b/src/Alpha.hs
--- a/src/Alpha.hs
+++ b/src/Alpha.hs
@@ -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
diff --git a/src/Compile.hs b/src/Compile.hs
--- a/src/Compile.hs
+++ b/src/Compile.hs
@@ -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
diff --git a/src/Compile/State.hs b/src/Compile/State.hs
--- a/src/Compile/State.hs
+++ b/src/Compile/State.hs
@@ -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
diff --git a/src/Compile/Utils.hs b/src/Compile/Utils.hs
--- a/src/Compile/Utils.hs
+++ b/src/Compile/Utils.hs
@@ -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]
diff --git a/src/Context.hs b/src/Context.hs
--- a/src/Context.hs
+++ b/src/Context.hs
@@ -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)
 
diff --git a/src/Context/Language.hs b/src/Context/Language.hs
--- a/src/Context/Language.hs
+++ b/src/Context/Language.hs
@@ -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
diff --git a/src/Context/Types.hs b/src/Context/Types.hs
--- a/src/Context/Types.hs
+++ b/src/Context/Types.hs
@@ -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 })
diff --git a/src/My/Control/Monad/RWTL.hs b/src/My/Control/Monad/RWTL.hs
--- a/src/My/Control/Monad/RWTL.hs
+++ b/src/My/Control/Monad/RWTL.hs
@@ -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)
diff --git a/src/My/Control/Monad/State.hs b/src/My/Control/Monad/State.hs
--- a/src/My/Control/Monad/State.hs
+++ b/src/My/Control/Monad/State.hs
@@ -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
 
diff --git a/src/My/Data/Relation.hs b/src/My/Data/Relation.hs
new file mode 100644
--- /dev/null
+++ b/src/My/Data/Relation.hs
@@ -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)
diff --git a/src/Options.hs b/src/Options.hs
--- a/src/Options.hs
+++ b/src/Options.hs
@@ -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
diff --git a/src/PCode/Instruction.hs b/src/PCode/Instruction.hs
--- a/src/PCode/Instruction.hs
+++ b/src/PCode/Instruction.hs
@@ -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
 
diff --git a/src/Specialize.hs b/src/Specialize.hs
--- a/src/Specialize.hs
+++ b/src/Specialize.hs
@@ -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]
diff --git a/src/Specialize/Types.hs b/src/Specialize/Types.hs
--- a/src/Specialize/Types.hs
+++ b/src/Specialize/Types.hs
@@ -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
diff --git a/src/Specialize/X86_64.hs b/src/Specialize/X86_64.hs
--- a/src/Specialize/X86_64.hs
+++ b/src/Specialize/X86_64.hs
@@ -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
diff --git a/src/Specialize/X86_64/Binary.hs b/src/Specialize/X86_64/Binary.hs
new file mode 100644
--- /dev/null
+++ b/src/Specialize/X86_64/Binary.hs
@@ -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')
+