packages feed

alpha 0.999 → 0.9999

raw patch · 16 files changed

+138/−105 lines, 16 files

Files

alpha.cabal view
@@ -1,5 +1,5 @@ name:           alpha-version:        0.999+version:        0.9999 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
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, ParallelListComp #-}+{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, ParallelListComp, TupleSections #-} import Compile import Context import Data.ByteString.Unsafe@@ -36,7 +36,7 @@   PrintVersion -> printVersion   Compile -> doCompile s -version = "0.999"+version = "0.9999" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version @@ -57,6 +57,7 @@     interactive = void $ compileFile "/dev/stdin"     compileProgram (readProg -> (language,root)) = withDefaultContext $ do       importLanguage compileLanguage (const $ return ()) language+      l <- doF languageF get       rootSym <- stateF languageF $ internSym root       getAddressComp (outputArch opts) rootSym       (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses@@ -64,28 +65,30 @@       contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size)                                        | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs]       writeElf root contents-    compileLanguage name = do-      source <- fromMaybe (error $ "Couldn't find source file for language "++name) $< findSource name+    compileLanguage force name = do       let langFile = languageFile name-      b <- doTestOlder <&&> fileExist langFile <&&> (langFile `newerThan` source)-      if b then either error id $< Ser.decode $< B.readFile langFile else do-        putStrLn $ "Compiling language "++name-        lang <- compileFile source-        createDirectoryIfMissing True (dropFileName langFile)-        B.writeFile langFile (Ser.encode lang)-        return lang-    loadLanguage name = compileLanguage name >>= execCode . initializeL >> languageState get+      source <- findSource name+      skip <- return (not force) <&&> fileExist langFile+              <&&> maybe (return True) (\s -> langFile `newerThan` s) source+      l <- if skip then either (\e -> error $ "Error reading language file "++langFile++": "++e)+                        id $< Ser.decode $< B.readFile langFile else do+             putStrLn $ "Compiling language "++name++"..."+             lang <- compileFile $ fromMaybe (error $ "Couldn't find source file for language "++name) source+             createDirectoryIfMissing True (dropFileName langFile)+             B.writeFile langFile (Ser.encode lang)+             return lang+      return (not skip,l)      compileFile src = withDefaultContext $ (>> gets language) $ do       str <- readFile src       let sTree = concat $ parseAlpha src str-      code <- mapM compileExpr sTree-      languageState $ modify $ \e -> exportLanguage $ e { initializeL = foldr concatCode [] code }+      init <- mapM compileExpr sTree+      languageState $ modify $ \e -> exportLanguage $ e { initializeL = init }       where compileExpr expr = do               symExpr <- languageState $ envCast expr               trExpr <- doTransform symExpr-              (code,imports) <- languageState $ compile Nothing trExpr-              mapM_ (importLanguage compileLanguage (execCode . initializeL)) imports+              (code,imports) <- languageState $ compile [] Nothing trExpr+              mapM_ (importLanguage compileLanguage (mapM_ execCode . initializeL)) imports               execCode code               return code
src/Compile.hs view
@@ -15,10 +15,11 @@ import PCode import Syntax -compile dest expr = runStateT st defaultState >§ \(code,cs) -> (code,imports cs)+compile args ret expr = runStateT st defaultState >§ \(code,cs) -> (code,imports cs)   where st = do-          (_,(start,_)) <- compile' dest expr-          simplify start >>= linearize --  >>= lift . uniquify+          (_,(start,_)) <- compile' (fmap bindSym ret) expr+          c <- simplify start >>= linearize >>= lift . uniquify args ret+          return $ Code args c ret  compile' dest (Symbol sym) = do   name <- getSymName sym@@ -93,17 +94,17 @@   compile' Nothing arg *>>= \v -> makeBackBranch v alts  compileAxiom XVerb dest [Group (name:args),expr] = do-  bindArgs <- mapM bindFromSyntax args-  (sym,ret,code) <- compileBody name expr-  lift $ modify $ exportSymVal sym (Verb (Code bindArgs code ret))+  (sym,code) <- compileBody args name expr+  lift $ modify $ exportSymVal sym (Verb code)   compile' dest (Symbol sym) compileAxiom XVerb dest [Symbol s,Symbol a] = do   lift $ modify $ \env -> exportSymVal s (lookupSymVal a env) env   compile' dest (Symbol s) compileAxiom XNoun dest [Symbol sym,size,init] = do-  (retSz,codeSz) <- compileExpr size-  (retInit,codeInit) <- compileExpr init-  lift $ modify $ exportSymVal sym $ Noun (Code [] codeSz (symBind retSz)) (Code [symBind sym] codeInit (symBind retInit))+  v <- newVar+  codeSz <- compileExpr [] (Just $ symBind v) size+  codeInit <- compileExpr [Symbol sym] Nothing init+  lift $ modify $ exportSymVal sym $ Noun codeSz codeInit   compile' dest (Symbol sym)  compileAxiom XLang _ [Symbol s] = do@@ -116,15 +117,16 @@  compileAxiom a _ args = error $ "Couldn't compile axiom "++show a++" with args "++show args -compileExpr expr = do-  ret <- newVar-  (code,imps) <- lift $ compile (Just ret) expr+compileExpr args ret expr = do+  args <- mapM bindFromSyntax args+  (code,imps) <- lift $ compile args ret expr   modifyF importsF (imps++)-  return (ret,code)-compileBody retBind body = do+  return code+compileBody args retBind body = do   bv <- bindFromSyntax retBind-  (ret,code) <- compileExpr body-  return (bindSym bv,bv { bindSym = ret },code)+  ret <- newVar+  code <- compileExpr args (Just bv { bindSym = ret }) body+  return (bindSym bv,code) compileValue dest val = do   c <- singleCode $< case dest of     Just v -> createNode (Instr $ set v val)
src/Compile/Utils.hs view
@@ -20,15 +20,21 @@  import Debug.Trace -uniquify [] = return []-uniquify code = flatten $< descendM desc M.empty $ spanningTree 0 nexts-  where (_,instr,nexts,_) = navigate code-        desc (instr -> Bind bv v) m = do+uniquify a r [] = uniquify a r [ret]+uniquify args ret code = flatten $< descendM uniq (M.fromList $ zip syms syms) $ spanningTree 0 nexts+  where syms = concatMap bindSyms $ maybe id (:) ret args+        (_,instr,nexts,_) = navigate code+        uniq (instr -> Bind bv v) m = do           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')-        desc i m = return (translate (translateBy m) (instr i),m)+        uniq i m = return (onF fstF (translate (translateBy m)) $ withLocals m $ instr i)+        localVal m (SymVal Value s) | not $ M.member s m = SymVal GValue s+        localVal m v = v         translateBy m s = fromMaybe s $ M.lookup s m+        withLocals m (Op b v vs) = (Op b v (map (localVal m) vs),M.insert v v m)+        withLocals m (Branch v a) = (Branch (localVal m v) a,m)+        withLocals m i = (i,m)  simplify :: Monad m => [Node] -> StateT CompileState m [Node] simplify start = do
src/Context.hs view
@@ -165,8 +165,7 @@   id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i   p <- getAddressJIT id   unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) -execCode [] = return ()-execCode instrs = evalCode mkProc execStub (Code [] instrs (symBind (ID (-1)))) id+execCode c = evalCode mkProc execStub c id  getAddress arch lookup register = withRef addressRef getAddr . getAddr   where
src/Context/Language.hs view
@@ -57,12 +57,19 @@                importLanguage getImport loadImport imp = merge imp   where -    merge imp = gets language >>= \l -> unless (imp`isImport`l) $ do-      l' <- getImport imp-      mapM_ merge [imp | (imp,_) <- BM.toList (languagesL l')]-      mergeLanguage l'+    merge imp = gets language >>= \l -> ifThenElse (imp`isImport`l) (return False) $ do+      (comp,l') <- getImport False imp+      comps <- mapM merge [imp | (imp,_) <- BM.toList (languagesL l')]+      let recomp = or comps+      l' <- if not comp && recomp then do+        (_,l') <- getImport True imp+        mapM merge [imp | (imp,_) <- BM.toList (languagesL l')]+        return l'+                else return l'+      mergeLanguage imp l'       loadImport l'-    mergeLanguage l' = doF languageF $ do+      return $ comp || recomp+    mergeLanguage imp l' = doF languageF $ do       let Language { symbolsL = syms' , languagesL = mods' , maxIDL = mi' } = l'       mapM_ (state . internSym) $ BM.keys syms'       Language { maxIDL = mi, symbolsL = syms } <- get@@ -82,9 +89,9 @@             return $ s'-r'+r           newVals = M.mapKeys tr $ M.map (translate tr) $ valuesL l'       modify $ \l -> l {-        languagesL = BM.insert imp (Range (mi,mi+mi')) (languagesL l),+        languagesL = BM.insert imp (Range (mi,mi+mi')) mods,         valuesL    = M.unionWith (\_ a -> a) (valuesL l) newVals,-        exportsL   = S.difference (exportsL l) (M.keysSet newVals) +        exportsL   = exportsL l S.\\ M.keysSet newVals          }            exportLanguage e = e {
src/Context/Types.hs view
@@ -32,7 +32,7 @@   languagesL  :: Bimap String (Range ID),   valuesL     :: Map ID Context.Types.Value,   exportsL    :: Set ID,-  initializeL :: [Instruction]+  initializeL :: [Code]   } symsF = Field (symbolsL,\s ce -> ce { symbolsL = s }) valsF = Field (valuesL,\v ce -> ce { valuesL = v })
src/ID.hs view
@@ -9,10 +9,10 @@ instance Ord a => Eq (Range a) where   a == b = compare a b == EQ instance Ord a => Ord (Range a) where-  compare (Range (a,b)) (Range (a',b')) =  -    if b<=a' then LT-    else if b'<=a then GT-         else EQ+  compare (Range (a,b)) (Range (a',b'))+    | b<=a' = LT+    | b'<=a = GT +    | otherwise = EQ  instance Enum ID where   toEnum = ID
src/My/Control/Monad/RWTL.hs view
@@ -47,8 +47,7 @@                               in (p',f',a,w))  listening m = censor (const mempty) $ do (_,w) <- listen m ; return w-withFuture m = future (do-                          f <- get+withFuture m = future (do f <- get                           f' <- lift $ future get                           ret <- lift $ m f                           put f'
src/My/Control/Monad/State.hs view
@@ -3,7 +3,7 @@   module Control.Monad.State,    Field(..),(<.>),   stateF,doF,modifyF,getF,getsF,putF,swapF,-  fstF,sndF,+  fstF,sndF,onF,   withState   ) where @@ -23,6 +23,8 @@ swapF f v                = stateF f (,v)   Field (f,f') <.> Field (g,g') = Field (g . f, (\g s -> f' (g' g (f s)) s)) ++onF (Field (t,t')) f x = t' (f (t x)) x  withState s mx = get >>= \v -> put s >> mx >>= \x -> put v >> return x
src/PCode/Instruction.hs view
@@ -23,7 +23,7 @@                  | Branch Value [Addr]                  | Bind BindVar (Maybe ID)                  | Noop-data Code = Code [BindVar] [Instruction] BindVar+data Code = Code [BindVar] [Instruction] (Maybe BindVar)             deriving Show  isNoop Noop = True@@ -55,8 +55,7 @@ isRet (Branch NullVal []) = True isRet _ = False -concatCode c1 [] = c1-concatCode c1 c2 = map (f g1) c1 ++ map (f g2) c2+concatCode (Code [] c1 _) (Code [] c2 r) = Code [] (map (f g1) c1 ++ map (f g2) c2) r   where f g (Branch v as) = Branch v (g as)         f _ i = i         g1 as = if null as then [l] else as@@ -72,13 +71,8 @@  spanArray bs tree = array bs (assocs Nothing tree)   where assocs p (Node a subs) = (a,(p,map rootLabel subs)):concatMap (assocs (Just a)) subs-codeRefs (Code args code ret) = refs code (bindSyms ret++concatMap bindSyms args)-  where refs code local = traverse (S.fromList local) (spanningTree 0 nexts)-          where (_,instr,nexts,_) = navigate code-                traverse local (Node i subs) = valRefs (instrVals (instr i)) ++ concatMap (traverse newLocal) subs-                  where valRefs vals = [v | SymVal t v <- vals, t==SymID || not (S.member v local)]-                        newLocal = S.union local (S.fromList (instrVars (instr i)))-        +codeRefs (Code args code ret) = [v | SymVal GValue v <- concatMap instrVals code]+ instance Show Instruction where     show (Op BCall d (f:args)) = show d ++ " = " ++ show f ++ "(" ++ intercalate "," (map show args) ++ ")"   show (Op BSet v [val]) = show v ++ " = " ++ show val
src/PCode/Value.hs view
@@ -8,7 +8,7 @@ import My.Prelude import ID -data ValType = Value | Address | Size | SymID+data ValType = Value | GValue | Address | Size | SymID              deriving Eq data Value = SymVal ValType ID            | IntVal Integer@@ -31,7 +31,7 @@          instance Show Value where   show (SymVal t v)   = prefix++show v-    where prefix = fromJust $ lookup t [(Value,""),(Address,"@"),(Size,"#"),(SymID,"$")]+    where prefix = fromJust $ lookup t [(Value,""),(Address,"@"),(Size,"#"),(SymID,"$"),(GValue,"")]   show (IntVal n)   = show n   show NullVal      = "(null)"
src/Specialize.hs view
@@ -75,17 +75,17 @@                   gen <- getsi fst ; fut <- getsi snd                   when (gen i < gen j) $ changeFuture i (gen j) (nextFuture j (fut j))     -    infos = constA bounds (Info env) `applyA` bindingsA `applyA` sizesA `applyA` activesA `applyA` clobbersA `applyA` localsA+    infos = constA bounds (Info env) `applyA` bindingsA `applyA` sizesA `applyA` activesA `applyA` clobbersA       where root i v = fmap fst $ M.lookup v (bindingsA!i)             bindingsA = treeArray next M.empty               where next _ bnd (Bind bv (Just id)) = insertMany bnd [(s,(id,n)) | (s,n,_) <- flattenBind defSize bv]                     next _ bnd _ = bnd-            sizesA = treeArray next (M.fromList [(s,n) | bv <- retVar:args, (s,_,n) <- flattenBind defSize bv])+            sizesA = treeArray next (M.fromList [(s,n) | bv <- maybe id (:) retVar args, (s,_,n) <- flattenBind defSize bv])               where next _ bnd (Bind bv _) = insertMany bnd [(s,n) | (s,_,n) <- flattenBind defSize bv]                     next _ bnd _ = bnd             activesA = fmap snd $ saturate fun prevs nexts init start               where init = array bounds [(i,initActives i) | i <- uncurry enumFromTo bounds]-                      where retActives = S.unions [clobbers 0 s | s <- bindSyms retVar]+                      where retActives = S.unions [clobbers 0 s | s <- maybe [] bindSyms retVar]                             initActives i = pair (if isRet (instr i) then retActives else mempty)                             pair a = (a,a)                     start = concat [prevs i | i <- indices init, isRet (instr i)]@@ -98,12 +98,8 @@                             addActives (Branch (SymVal Value id) _) s = s <> clobbers i id                              addActives (Bind bv v) s = maybe id S.insert v $ s S.\\ S.fromList (bindSyms bv)                             addActives _ s = s-            localsA = treeArray next (S.fromList [v | bv <- retVar:args, v <- bindSyms bv])-              where next _ s (Bind bv _) = s `S.union` S.fromList (bindSyms bv)-                    next _ s (Op _ v _) = S.insert v s-                    next _ s _ = s             clobbers i v = fromMaybe (S.singleton v) $ R.lookupRan v (clobbersA!i)-            clobbersA = treeArray next (foldl (next undefined) R.empty [Bind bv Nothing | bv <- retVar:args])+            clobbersA = treeArray next (foldl (next undefined) R.empty [Bind bv Nothing | bv <- maybe id (:) retVar args])               where next i r (Bind bv v) = insertManyA r assocs                       where assocs = [(bindSym bv,s) | bv <- bindNodes bv                                                      , s <- bindSyms bv]
src/Specialize/Types.hs view
@@ -34,7 +34,7 @@ data Architecture = Arch {   archName         :: String,   archDefaultSize  :: Int,-  archInitials     :: [BindVar] -> BindVar -> (MemState,Future),+  archInitials     :: [BindVar] -> Maybe BindVar -> (MemState,Future),   archCompileInstr :: Instruction -> RWTL Info BinCode MemState Future ()   } data MemState = MemState {@@ -53,16 +53,14 @@   sizes      :: Map ID Int,   actives    :: Set ID,   clobbers   :: Relation ID ID,-  locals     :: Set ID,   branchPos  :: (Int,Int -> (Int,Int,Maybe MemState))   }  instance Show Info where-  show (Info _ b sz a c l _) = "Info { bindings = "++show b+  show (Info _ b sz a c _) = "Info { bindings = "++show b                                ++", sizes = "++show sz                                ++", actives = "++show a                                ++", clobbers = "++show c-                               ++", locals = "++show l                                ++" }"  registersF  = Field (registers  ,\r p -> p { registers = r })
src/Specialize/X86_64.hs view
@@ -183,13 +183,15 @@ (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+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 >> neg d+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 >> neg d+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@@ -213,9 +215,8 @@ argVal (IntVal n) = Right $ withSize n argVal (SymVal Size s) = Right $ withSize $ fromMaybe defSize $ M.lookup s (sizes ?info) argVal (SymVal SymID (ID s)) = Right $ withSize $ s-argVal (SymVal _ s) = maybe (Left s) (Right . (defSize*8,)) $ globVal s-globVal s = if isLocal s then Nothing else Just (toInteger $< snd (envInfo ?info) s)-isLocal s = S.member s (locals ?info)+argVal (SymVal GValue s) = Right (defSize*8,toInteger $< snd (envInfo ?info) s)+argVal (SymVal _ s) = Left s binding s = M.lookup s (bindings ?info) isActive s = S.member s (actives ?info) varSize s = fromMaybe defSize (M.lookup s $ sizes ?info) @@ -232,7 +233,7 @@ frameToStack sz n = -(n+sz) lookupSymIn = flip BM.lookupR lookupRegIn = flip BM.lookup-argValSym (SymVal Value s) | isLocal s = Just s+argValSym (SymVal Value s) = Just s argValSym _ = Nothing lookupArgReg arg m = argValSym arg >>= lookupRegIn m @@ -354,8 +355,9 @@         (retReg:funReg:argRegs) = allocRegs         pregs = BM.fromList [(bindSym v,r) | (r,v) <- regs]         frame = foldr (frameAlloc defSize) emptyFrame (stArgs++nonRegs)-        fr | bSize ret<=defSize = BM.singleton (bindSym ret) retReg-           | otherwise = BM.empty+        fr = case ret of+          Just ret | bSize ret<=defSize -> BM.singleton (bindSym ret) retReg+          _ -> BM.empty  storeFlags s = do   regs <- gets registers@@ -387,8 +389,8 @@     storeRegs [r | (s,r) <- BM.toList regs, not (isActive s), isJust (binding s)]     lift $ modifyF registersF (BM.filter (const . isActive)) compile' (Branch v alts) = withFreeSet $ do-  let alignPast i = maybe doNothing (preserve . alignWith . registers) (instrPast i)-      jmpc short long (BC (e,s,_)) (BC (e',s',_)) = BC (length long+4,length code,return $ B.pack code)+  let alignPast i = listening $ maybe doNothing (preserve . alignWith . registers) (instrPast i)+      jmpc short long (BC ~(e,s,_)) (BC ~(e',s',_)) = BC (length long+4,length code,return $ B.pack code)         where de = e'-e ; ds = s'-s               code | de==0 = []                    | de > -128 && de<=128 = short++take 1 (bytes ds)@@ -397,6 +399,19 @@       start i = BC (est,pos,undefined) where (est,pos) = instrAddress i    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)+      tellCode [0xc3]+    [def] -> do+      al <- alignPast def+      let [_,_,p] = scanl mappend (start thisInstr) codes+          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)@@ -406,26 +421,36 @@             [Left r] <- unReadFuture (loadArgs [(v,Nothing)])             cmpri r r (withSize (0 :: Int))             return r-      [al,al'] <- mapM (listening . alignPast) [def,null]+      [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       mapM_ tell codes-    [def] -> do-      al <- listening $ alignPast def-      let [_,_,p] = scanl mappend (start thisInstr) codes-          codes = [al,jmp p (start def)]+    alts@(def:rest) -> readFuture $ do+      ([Left r],c) <- listen $ unReadFuture $ loadArgs [(v,Nothing)]+      (_,c') <- listen $ cmpri r r (withSize (length alts))+      (alDef:alRest) <- mapM alignPast alts+      let codes = [jmpc [0x72] [0x0f,0x82] cmpP testP+                  ,alDef <> jmp testP (start def)+                  ,execWriter $ do+                    movi rsi (64,posAddr tableP)+                    tellCode [fi $ fromFields [(0,1),(r`shiftR`3,1),(0x12,6)]+                             ,0xff,0x24+                             ,fi $ fromFields [(0x6,3),(r.&.7,3),(0x3,2)]]+                  ,fromBytesN (defSize*(length alts-1)) (concat $< mapM (liftM (take defSize . bytes) . posAddr)+                                                         restDsts)]+                  ++ restCodes+          (restDsts,restCodes) = unzip [if isEmptyCode al+                                        then (start alt,mempty)+                                        else (p, let p' = p<>c ; c = al<>jmp p' (start alt) in c)+                                       | al <- alRest+                                       | p <- restPs +                                       | alt <- rest]+          (_:cmpP:testP:tableP:restPs) = scanl mappend (start thisInstr<>c<>c') codes+          posAddr (BC ~(_,a,_)) = verbAddress >§ \va -> toInteger $ va+snd (instrAddress thisInstr)+a       mapM_ tell codes-    [] -> readFuture $ do-      p <- lift get-      let isPresent s _ = isJust $ msum [void $ binding s-                                        ,void $ lookupAddr s (frame p)-                                        ,void $ lookupRegIn (registers p) s]-      (_,fregs) <- lift $ regInfo-      unReadFuture $ alignWith (BM.filter isPresent fregs)-      tellCode [0xc3]  compile' (Bind bv arg) = do   future $ modifyF fregistersF $ \rs -> foldr BM.delete rs (bindSyms bv)@@ -470,7 +495,7 @@     addri rsp rsp $ withSize top     lift $ associate rax (Just d) -compileOp b d [s] | b`elem`[BSet,BSetSX] && varSize d<=defSize = withFreeSet $ do+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@@ -479,6 +504,8 @@     when (argSize s < varSize d) $ case b of       BSet -> zxtnd r' (argSize s)       BSetSX -> sxtnd r' (argSize s)+      BNot -> notr r'+      BSub -> negr r'     lift $ associate r' (Just d)  compileOp b d [a,a'] | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do
src/Translate.hs view
@@ -28,7 +28,7 @@   translate tr (SymVal t id) = SymVal t (translate tr id)   translate tr v = v instance Translatable Code where-  translate tr (Code args code ret) = Code (translate tr args) (translate tr code) (translate tr ret)+  translate tr (Code args code ret) = Code (translate tr args) (translate tr code) (fmap (translate tr) ret) instance Translatable BindVar where   translate tr (BindVar id s pad subs) = BindVar (translate tr id) s pad [(translate tr bv,s) | (bv,s) <- subs]