diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 0.9.9.5 +version: 0.99 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 @@ -22,8 +22,7 @@ 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 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.RWTL My.Control.Monad.State 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.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 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 @@ -34,9 +34,9 @@ execute s = case action s of PrintHelp -> printHelp PrintVersion -> printVersion - Compile -> print s >> doCompile s + Compile -> doCompile s -version = "0.9.9" +version = "0.99" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version @@ -63,8 +63,8 @@ top <- gets compTop contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs] - writeElf language contents - compileLanguage name = debugM $ do + writeElf root contents + compileLanguage name = do source <- fromMaybe (error $ "Couldn't find source file for language "++name) $< findSource name let langFile = languageFile name b <- doTestOlder <&&> fileExist langFile <&&> (langFile `newerThan` source) @@ -81,9 +81,8 @@ let sTree = concat $ parseAlpha src str code <- mapM compileExpr sTree languageState $ modify $ \e -> exportLanguage $ e { initializeL = foldr concatCode [] code } - where compileExpr expr = print (fmap Str expr) >> do + where compileExpr expr = do symExpr <- languageState $ envCast expr - print symExpr trExpr <- doTransform symExpr (code,imports) <- languageState $ compile Nothing trExpr mapM_ (importLanguage compileLanguage (execCode . initializeL)) imports diff --git a/src/Compile/Utils.hs b/src/Compile/Utils.hs --- a/src/Compile/Utils.hs +++ b/src/Compile/Utils.hs @@ -24,7 +24,7 @@ where (_,instr,nexts,_) = navigate code desc (instr -> Bind bv v) m = do news <- mapM (const $ state createSym) (bindSyms bv) - let m' = debug $ foldr (uncurry M.insert) m (zip (bindSyms bv) news) + 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) translateBy m s = fromMaybe s $ M.lookup s m diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -6,27 +6,29 @@ ,doTransform ,getAddressComp ,execCode) where -import System.IO.Unsafe (unsafePerformIO) import Bindings.Posix.Sys.Mman -import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) -import Foreign.C -import Foreign.ForeignPtr.Unsafe -import Data.Maybe +import Context.Language as Lang +import Context.Language +import Context.Types +import Data.ByteString import Data.ByteString.Unsafe -import qualified Data.Map as M import Data.Functor.Identity import Data.IORef +import Data.Maybe +import qualified Data.Map as M +import Elf(entryAddress) +import Foreign.C +import Foreign.ForeignPtr.Unsafe +import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) +import ID import My.Control.Monad import My.Control.Monad.State - -import Context.Types -import Context.Language -import Specialize import PCode -import ID -import Elf(entryAddress) -import Syntax +import Specialize import Specialize.Architecture +import Syntax +import System.IO.Unsafe (unsafePerformIO) +import My.Prelude foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt @@ -64,7 +66,7 @@ doTransform syn = gets transform >>= ($syn) initialContext = C lang jitA M.empty (fromIntegral entryAddress) return - where (lang,jitA) = execState (mapM_ st initialBindings) (empty,M.empty) + where (lang,jitA) = execState (mapM_ st initialBindings) (Lang.empty,M.empty) where st (s,v) = do i <- stateF fstF (internSym s) case v of @@ -76,9 +78,9 @@ contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a languageState = contextState . doF languageF -foreign import ccall "dynamic" mkProc :: FunPtr (IO ()) -> IO () -foreign import ccall "dynamic" mkFunSize :: FunPtr (IO Int) -> IO Int -foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> IO ()) -> Ptr () -> IO () +foreign import ccall "dynamic" mkProc :: FunPtr (Ptr() -> IO ()) -> Ptr() -> IO () +foreign import ccall "dynamic" mkFunSize :: FunPtr (Ptr() -> IO Int) -> Ptr() -> IO Int +foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO () getAddress arch lookup register = withRef addressRef getAddr . getAddr where @@ -94,19 +96,20 @@ unsafeUseAsCStringLen code $ \(p',n) -> copyBytes p (castPtr p') n mprotect (castPtr p) (fromIntegral size) (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC) Noun size init -> do - size <- join $ evalCode mkFunSize size + size <- join $ evalCode mkFunSize execStub size ptr <- mallocForeignPtrBytes size register id ptr size - withForeignPtr ptr $ \p -> evalCode mkFunInit init >>= ($castPtr p) + withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init >>= ($castPtr p) _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show id) (lookupSymName id lang) -evalCode :: (FunPtr f -> f) -> Code -> IO f -evalCode wrap code = do +evalCode :: (FunPtr (Ptr() -> a) -> (Ptr() -> a)) -> ByteString -> Code -> IO a +evalCode wrap stub code = do id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i p <- getAddressJIT id - return $ wrap $ castPtrToFunPtr $ intPtrToPtr $ fromIntegral p + unsafeUseAsCString stub $ \stub -> + return $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) execCode [] = return () -execCode instrs = join $ evalCode mkProc (Code [] instrs (symBind (ID (-1)))) +execCode instrs = join $ evalCode mkProc execStub (Code [] instrs (symBind (ID (-1)))) getAddressJIT = getAddress hostArch lookup register where lookup id = do diff --git a/src/My/Control/Monad.hs b/src/My/Control/Monad.hs --- a/src/My/Control/Monad.hs +++ b/src/My/Control/Monad.hs @@ -1,5 +1,11 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -module My.Control.Monad (module Control.Monad,($<),(>$),(>$<),(§),(§<),(>§),(>§<),(<&&>),(<||>),ifM,findM,lift2) where +module My.Control.Monad (module Control.Monad + ,($<),(>$),(>$<) + ,(§),(§<),(>§),(>§<) + ,(<&&>),(<||>) + ,ifM,findM + ,lift2 + ,doNothing) where import Control.Monad import Control.Monad.Trans @@ -29,3 +35,4 @@ findM p l = foldr fun (return Nothing) l where fun x ret = ifM (p x) (return $ Just x) ret +doNothing = return () 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 @@ -4,7 +4,7 @@ ,get,put ,ask,local ,tell,listen,pass,listening - ,future) where + ,future,withFuture) where import Data.Monoid import Control.Monad.State @@ -19,14 +19,18 @@ fth4 (_,_,_,a) = a instance Monoid w => Monad (RWTL r w p f) where - rw >>= cc = RWTL rw' - where rw' r p f = (p'',f'',b,w`mappend`w') - where (p',f'',a,w) = runRWTL rw r p f' + tl >>= cc = RWTL tl' + where tl' r p f = (p'',f'',b,w`mappend`w') + where (p',f'',a,w) = runRWTL tl r p f' (p'',f',b,w') = runRWTL (cc a) r p' f return a = RWTL (\r p f -> (p,f,a,mempty)) +-- the Monoid constraint is not necesary if you want to be precise, +-- but the alternative to liftM would be extremely ugly +instance Monoid w => Functor (RWTL r w p f) where + fmap = liftM class MonadFuture f m | m -> f where - future :: (State f a) -> m a + future :: (StateT f m a) -> m a instance Monoid w => MonadState p (RWTL r w p f) where get = RWTL (\_ p f -> (p,f,p,mempty)) @@ -39,6 +43,13 @@ listen (RWTL rw) = RWTL (\r p f -> let (p',f',a,w) = rw r p f in (p',f',(a,w),w)) pass (RWTL rw) = RWTL (\r p f -> let (p',f',(a,m),w) = rw r p f in (p',f',a,m w)) instance Monoid w => MonadFuture f (RWTL r w p f) where - future st = RWTL (\r p f -> let ~(a,f') = runState st f in (p,f',a,mempty)) + 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) diff --git a/src/My/Prelude.hs b/src/My/Prelude.hs --- a/src/My/Prelude.hs +++ b/src/My/Prelude.hs @@ -3,12 +3,13 @@ import System.Posix.Files import Data.Maybe -import Debug.Trace +import Debug.Trace as Tr import My.Control.Monad +debugMess mess x = Tr.trace (mess++show x) x debug x = traceShow x x debugM = liftM debug -trace = Debug.Trace.trace +trace = Tr.trace maybeToEither = maybe (Left undefined) Right eitherToMaybe = either (const Nothing) Just diff --git a/src/PCode/Value.hs b/src/PCode/Value.hs --- a/src/PCode/Value.hs +++ b/src/PCode/Value.hs @@ -16,6 +16,7 @@ varEqVal n (SymVal Value n') = n==n' varEqVal _ _ = False +symValType (SymVal t _) = t readConstant s = let (a,b) = break (=='#') (filter (/='-') s) in eitherToMaybe $ parseInt 10 a >>= \r -> if null b then return r else parseInt r (tail b) diff --git a/src/Specialize.hs b/src/Specialize.hs --- a/src/Specialize.hs +++ b/src/Specialize.hs @@ -28,7 +28,9 @@ import My.Prelude import Debug.Trace -specialize arch env (Code args code retVar) = seq (debug instructions') (sum sizes,B.concat $< sequence codes) +worldID = ID (-1) + +specialize arch env (Code args code retVar) = (sum sizes,B.concat $< sequence codes) where ~(estimates,sizes,codes) = unzip3 [v | BC v <- elems instructions] (past,future) = archInitials arch args retVar @@ -37,9 +39,11 @@ positions = listArray bounds posList posList = [(e,s) | e <- sums estimates | s <- sums sizes] codeTree = spanningTree 0 nexts - runInstr i p f past = runRWTL (compile $ instr i) ((infos!i) (i,getPos)) p f + runInstr i p f past = runRWTL (compile (instr i) >> align) ((infos!i) (i,getPos)) p f where compile = archCompileInstr arch getPos j = (e,d,past j) where ~(e,d) = positions!j + align | not (isBranch (instr i)) && length (prevs $ head $ nexts i) > 1 = compile Noop + | otherwise = doNothing treeArray next seed = array bounds $ flatten $ descend (\i e -> ((i,e),next i e (instr i))) seed codeTree @@ -80,7 +84,10 @@ 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 = listArray bounds (repeat (S.empty,S.empty)) + where init = array bounds [(i,initActives i) | i <- uncurry enumFromTo bounds] + where retActives = S.unions [clobbers 0 s | s <- 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)] fun i a = (addActives (instr i) out,out) where out = S.unions (map ((a!) >>> fst) (nexts i)) @@ -88,7 +95,7 @@ <> 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]) - addActives (Branch (SymVal Value id) _) s = s <> clobbers i id + addActives (Branch (SymVal Value id) _) s = s <> clobbers i id addActives (Bind _ v) s = maybe id S.insert v s addActives _ s = s localsA = treeArray next (S.fromList [v | bv <- retVar:args, v <- bindSyms bv]) @@ -97,22 +104,23 @@ 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]) - where next i r (Bind bv v) = insertManyR r assocs - where assocs = [ass | bv <- bindNodes bv - , s <- bindSyms bv - , ass <- [(bindSym bv,s),(s,bindSym bv)]] - ++[ass | v <- maybeToList v - , ref <- S.toList $ references i v - , s <- maybe [v] S.toList (R.lookupRan ref r) - , ass <- [(s,ref),(ref,s)]] + 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)] + next i r (Op BCall d (_:args)) = insertManyA r assocs + where assocs = map (worldID,) $ d : argRefs i args next _ r _ = r - lookupRefs v r = fromMaybe (S.singleton (ID (-1))) $ R.lookupRan v 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 + 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 R.empty - where next i r (Op _ v vs) = insertManyR r' (map (v,) $ S.toList refs) + referencesA = treeArray next $ insertManyR R.empty [(worldID,s) | arg <- args, s <- bindSyms arg] + where next i r (Op _ v vs) = insertManyR r' (map (v,) $ argRefs i vs) where r' = S.delete v (R.dom r) R.<| r - refs = S.fromList [s | SymVal Address s <- vs] - <> S.unions [lookupRefs v r | SymVal Value s <- vs] next _ r _ = r constA bs v = accumArray const v bs [] diff --git a/src/Specialize/Architecture.hs b/src/Specialize/Architecture.hs --- a/src/Specialize/Architecture.hs +++ b/src/Specialize/Architecture.hs @@ -1,7 +1,13 @@ -module Specialize.Architecture(Architecture(..),arch_x86,arch_x86_64,arch_arm,hostArch,architectures) where +module Specialize.Architecture(Architecture(..) + ,arch_x86 + ,arch_x86_64 + ,arch_arm + ,hostArch,Specialize.Architecture.execStub,Specialize.Architecture.initStub + ,architectures) where import Specialize.Types -import Specialize.X86_64 +import Specialize.X86_64 as Host +import System.IO.Unsafe (unsafePerformIO) instance Eq Architecture where a == a' = archName a == archName a' @@ -17,3 +23,5 @@ hostArch = arch_x86_64 { archName = "host" } +execStub = unsafePerformIO Host.execStub +initStub = unsafePerformIO Host.initStub diff --git a/src/Specialize/Types.hs b/src/Specialize/Types.hs --- a/src/Specialize/Types.hs +++ b/src/Specialize/Types.hs @@ -5,7 +5,7 @@ ,Architecture(..) ,Info(..) ,MemState(..),Future(..), emptyFuture - ,frameF, registersF) where + ,frameF, registersF, fregistersF) where import Data.Bimap import Data.ByteString @@ -56,5 +56,6 @@ frameF = Field (frame,\f p -> p { frame = f }) registersF = Field (registers,\r p -> p { registers = r }) +fregistersF = Field (fregisters,\r f -> f { fregisters = r }) emptyFuture = Future Data.Bimap.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,11 +1,12 @@ {-# LANGUAGE ViewPatterns, TupleSections, ParallelListComp, ImplicitParams, NoMonomorphismRestriction, Rank2Types #-} -module Specialize.X86_64(arch_x86_64) where +module Specialize.X86_64(arch_x86_64,execStub,initStub) where import Control.Monad.Writer.Class import Control.Arrow import Control.Monad.Reader import Control.Monad.Trans +import Control.Monad.Writer import Data.Bits import Data.Char import Data.Function @@ -37,6 +38,21 @@ ,Integer -> Integer -> Integer) arch_x86_64 = Arch "x86_64" defSize defaults compile +(execStub,initStub) = (writerStub exec,writerStub init) + where callStub loadArgs = do + mapM_ push saved + loadArgs + call rdi + mapM_ pop saved + tellCode [0xc3] + saved = rbx:rbp:[r12..r15] + init = callStub (mov rdx rsi) + exec = callStub (return ()) + 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) = @@ -45,6 +61,8 @@ 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 @@ -54,7 +72,6 @@ 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) -frameToStack n = (-8)-fi n fromBytesN n ml = BC (n,n,liftM B.pack ml) fromBytes c = fromBytesN (length c) (return c) @@ -111,9 +128,12 @@ 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++code++suf + else tellCode $ pre'++pre++code++suf where (pre,suf) = argBytesWide (sz==8) d s (Just (n+i)) - code = fromJust (lookup sz [(8,[0x8b]),(4,[0x8b]),(2,[0x66,0x8b]),(1,[0x8a])]) + (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 () @@ -126,10 +146,13 @@ 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++code++suf) + else tellCode $ pre'++pre++code++suf) sh sz where (pre,suf) = argBytesWide (sz==8) s d (Just (n+i)) - code = fromJust (lookup sz [(8,[0x89]),(4,[0x89]),(2,[0x66,0x89]),(1,[0x88])]) + (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) @@ -158,7 +181,7 @@ calli pos (_,v) = tell $ fromBytesN 5 (liftM2 (\p v -> [0xe8]++take 4 (bytes (v-fi p-5))) pos v) call r = tellCode $ pre++[0xff]++post - where (pre,post) = argBytes 2 r Nothing + 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' @@ -166,24 +189,28 @@ (Right v,Left r) -> ir dest v r (Right (s,n),Right (s',n')) -> movi dest (max s s',liftM2 ii n n') -associate d r = modifyF registersF $ BM.insert d r -frameAddr s = stateF frameF (withAddr defSize s) +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 -lookupArgReg (SymVal Value s) m = BM.lookup s m -lookupArgReg _ _ = Nothing +argValSym (SymVal Value s) = Just s +argValSym _ = Nothing +lookupArgReg arg m = argValSym arg >>= lookupRegIn m -miscInfos = ask >>= \info -> do - let 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 - globVal s = if isLocal s then Nothing else Just (fi $< snd (envInfo info) s) - isLocal s = S.member s (locals info) - binding s = M.lookup s (bindings info) - return (argVal,globVal,isLocal,binding) +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 +globVal s = if isLocal s then Nothing else Just (toInteger $< snd (envInfo ?info) s) +isLocal s = S.member s (locals ?info) +binding s = M.lookup s (bindings ?info) +isActive s = S.member s (actives ?info) +varSize s = fromMaybe defSize (M.lookup s $ sizes ?info) +argSize (SymVal Value s) = varSize s +argSize _ = defSize -withFreeSet m = liftM3 (,,) ask get (future get) >>= \(i,p,f) -> do +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 @@ -194,75 +221,69 @@ (Just v,Just v') -> (isActive v`compare`isActive v')`mappend`compare r r' regVar = lookupSymIn $ registers p fRegVar = lookupSymIn $ fregisters f - isActive v = S.member v $ actives i evalStateT m (SB.fromList cmp allocRegs) -protectFuture m = StateT s +readFuture m = StateT s where s t = RWTL (\r p f -> let ~(p',_,a,w) = runRWTL (runStateT m t) (r,f) p undef in (p',f,a,w)) undef = error "Illegal use of protected future" -unProtectFuture m = StateT s +unReadFuture m = StateT s where s t = RWTL (\(r,f) p _ -> runRWTL (runStateT m t) r p f) preserve m = StateT s - where s t = RWTL (\r p f -> let (_,f',a,w) = runRWTL (runStateT m t) r p f in (p,f',a,w) ) - -infos = liftM3 (,,) (asks fst) get (asks snd) -varSize s = fromMaybe defSize $< asks (M.lookup s . sizes . fst) -argSize (SymVal Value s) = varSize s -argSize _ = return defSize + where s t = RWTL (\r p f -> let (_,_,a,w) = runRWTL (runStateT m t) r p f in (p,f,a,w) ) +regInfo = liftM2 (,) (gets registers) (asks (fregisters . snd)) -allocReg sym = asks (fregisters . snd) >>= \regs -> do +allocReg sym = lift regInfo >>= \(_,regs) -> do let st free = (r,SB.delete r free) where r | SB.null free = r15 - | otherwise = fromMaybe (SB.findMin free) $ mfilter (`SB.member`free) $ lookupRegIn regs sym - r <- state st - return r + | otherwise = fromMaybe (SB.findMin free) $ mfilter (`SB.member`free) + $ lookupRegIn regs sym + state st -destRegister d = lift infos >>= \(i,p,f) -> - case mfilter (\r -> maybe True (==d) $ BM.lookupR r (registers p)) $ lookupRegIn (fregisters f) d of +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 Just r -> return r Nothing -> storeRegs [head allocRegs] >> return (head allocRegs) - where findReg s = lookupSymIn (registers p) s `mplus` lookupSymIn (fregisters f) s + where findReg s = lookupSymIn regs s `mplus` lookupSymIn fregs s -loadRoot (Just s) = lift get >>= \p -> case lookupRegIn (registers p) s of +loadRoot (Just s) = lift regInfo >>= \(regs,_) -> case lookupRegIn regs s of Just r -> return r Nothing -> do r <- allocReg s a <- lift (frameAddr s) - lift $ associate s r + lift $ associate r (Just s) ld r (rsp,fi a,defSize) return r loadRoot Nothing = return rsp -storeRegs regs = lift get >>= \p -> do - (_,_,_,binding) <- unProtectFuture miscInfos - let vars = [(r,s,binding s) | (r,Just s) <- zip regs (map (lookupSymIn (registers p)) regs)] +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 reg <- loadRoot $ parent $ head g - mapM_ (store reg) g + lift $ mapM_ (store reg) g where store base (r,s,b) = do - n <- maybe (lift $ frameAddr s) (return . snd) b - sz <- varSize s - st (base,frameToStack n,fi sz) r + n <- maybe (frameAddr 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 (registers p) + where isFree = isNothing . lookupSymIn regs restrict $ mapM_ storeGroup groups lift $ modifyF registersF $ \rs -> foldr BM.delete rs [s | (_,s,_) <- vars] loadArgs args = do - lift $ future $ modify $ \f -> f { fregisters = foldr (uncurry BM.insert) (fregisters f) - [(s,r) | (SymVal Value s,Just r) <- args] } - protectFuture $ do - (argVal,globVal,isLocal,binding) <- unProtectFuture miscInfos - p <- lift get + let modFRegs regs = foldr ($) regs [maybe (BM.deleteR r) (flip BM.insert r) $ argValSym arg + | (arg,Just r) <- args] + lift $ future $ modifyF fregistersF $ modFRegs + readFuture $ do + (regs,_) <- lift regInfo let fixed = mapMaybe snd args - argAlloc (arg,Nothing) = runKleisli (left $ k f) (argVal arg) - where f s = get >§ \free -> maybe (Left s) Right $ mfilter (`SB.member` free) (BM.lookup s (registers p)) + argAlloc (arg,Nothing) = leftK f (argVal arg) + where f s = get >§ \free -> maybe (Left s) Right + $ mfilter (`SB.member` free) (BM.lookup s regs) argAlloc (_,Just r) = return (Left $ Right r) - argNew = runKleisli (left $ k allocReg ||| k return) + argNew = leftK (allocReg <|||> return) modify $ \s -> foldr SB.delete s fixed alls <- mapM argAlloc args modify $ \s -> foldr SB.delete s [r | Left (Right r) <- alls] @@ -273,23 +294,31 @@ bind _ = Nothing groups = classesBy ((==)`on`parent) assocs parent (_,_,b) = fmap fst b - myWorkIsDone r s = lookupRegIn (registers p) s == Just r + myWorkIsDone r s = lookupRegIn regs s == Just r loadGroup g = do - base <- loadRoot $ parent $ head g + base <- loadRoot (parent $ head g) mapM_ (load base) g - where load base (r,arg,b) = case argVal arg of - Right v -> movi r v - Left s -> do - n <- maybe (lift $ frameAddr s) return $ fmap snd b - sz <- varSize s - let SymVal t _ = arg - if t==Value then ld r (base,frameToStack n,fi sz) else lea r base (fi n) - - storeRegs [r | (r,_,_) <- assocs] + where load base (r,arg,b) = lift regInfo >>= \(regs,_) -> do + when (isJust $ lookupSymIn regs r) (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 + if symValType arg == Value + then ld r (base,fi n,fi (varSize s)) + else lea r base (fi n) + lift $ associate r ((Just ||| const Nothing) $ argVal arg) + mapM_ loadGroup groups - lift $ modifyF registersF $ \m -> foldr (uncurry BM.insert) m [(s,r) | ((SymVal _ s,_),Left r) <- zip args allocs] return allocs +alignWith regs = do + loadArgs [(SymVal Value s,Just r) | (s,r) <- BM.toList regs] + free <- get + readFuture $ storeRegs (SB.toList free) + defaults args ret = (MemState pregs frame,Future fr) where (regArgs,stArgs) = partition ((<=defSize) . bSize) args (regs,nonRegs) = zipRest argRegs regArgs @@ -299,17 +328,72 @@ fr | bSize ret<=defSize = BM.singleton (bindSym ret) retReg | otherwise = BM.empty -compile (Op BCall d (fun:args)) = withFreeSet $ do +compile i = ask >>= \info -> let ?info = info in compile' i + +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 + 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 + code | de==0 = [] + | de > -128 && de<=128 = short++take 1 (bytes da) + | otherwise = long++take 4 (bytes da) + jmp = jmpc [0xeb] [0xe9] + start i = BC (est,pos,undefined) where (est,pos,_) = brInfo i + + case alts of + [def,null] -> do + (r,c) <- 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 + [al,al'] <- mapM (listening . alignPast) [def,null] + let [_,_,p1,_,p2,_,p3] = scanl mappend (start instr) 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 + mapM_ tell codes + [def] -> do + al <- listening $ alignPast def + let [_,_,p] = scanl mappend (start instr) codes + codes = [al,jmp p (start def)] + mapM_ tell codes + [] -> readFuture $ do + p <- lift get + let isPresent s _ = isJust $ msum [void $ binding s + ,void $ lookupAddr s (frame p) + ,void $ lookupRegIn (registers p) s] + (_,fregs) <- lift $ regInfo + unReadFuture $ alignWith (BM.filter isPresent fregs) + tellCode [0xc3] + +compile' (Bind bv Nothing) = modifyF frameF (frameAlloc defSize bv) +compile' (Bind bv _) = return () +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 - sizes <- protectFuture $ mapM argSize args - let (MemState regs subFrame,_) = defaults [BindVar id (sz,0) 0 [] | (id,arg) <- argAssocs | sz <- sizes] 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 - (argVal,_,_,binding) <- miscInfos + modify (SB.delete rax) - (func:_,cload) <- listen $ loadArgs $ (fun,Nothing):[(arg,r) | (id,arg) <- argAssocs, let r = BM.lookup id regs, isJust r] - protectFuture $ do + (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) top <- lift $ gets (frameTop . frame) @@ -318,8 +402,8 @@ 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 - sz <- argSize arg 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 @@ -327,85 +411,51 @@ (_,cstore') <- listen $ do lift $ mapM_ storeBig argAssocs subi rsp rsp $ withSize top - let pos = thisFunc >§ \p -> p+instrPos+delta + let pos = thisFunc >§ (+(instrPos+delta)) BC ~(_,delta,_) = cload <> cstore <> cstore' (_,instrPos,_) = brInfo instr ; thisFunc = addrs myID - runKleisli (k call ||| k (calli pos)) func + (call <|||> calli pos) func addi rsp rsp $ withSize top + lift $ associate rax (Just d) -compile (Op BSet d [s]) = withFreeSet $ do +compileOp BSet d [s] = withFreeSet $ do [v] <- loadArgs [(s,Nothing)] - protectFuture $ do - dest <- destRegister d - runKleisli (k (mov dest) ||| k (movi dest)) v - lift $ associate d dest -compile (Op b d [a,a']) | b`elem`[BAdd,BSub,BMul,BAnd,BOr,BXor] = withFreeSet $ do + 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 + 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)] [v,v'] <- loadArgs [(a,Nothing),(a',Nothing)] - protectFuture $ do + readFuture $ do dest <- destRegister d opsCode ops dest v v' - lift $ associate d dest + 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)] 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)] - protectFuture $ do + readFuture $ do opsCode (cmps $ convert $ fromJust (lookup b applys)) dest v v' - lift $ associate d dest + lift $ associate dest (Just d) | b`elem`[BMod,BDiv] = withFreeSet $ do - protectFuture $ storeRegs [rdx] - movi rdx $ withSize (0 :: Int) - [_,v] <- loadArgs [(a,Just rax),(a',Nothing)] - protectFuture $ case v of - Left r -> op [0xf7] 7 7 r - Right v -> opi (codeFun []) [0xf7] 7 7 v - lift $ associate d (case b of BMod -> rdx ; BDiv -> rax) - -compile (Op b d args@(a:a':t)) | isBinOp b = mapM_ compile $ Op b d [a,a']:[Op b d [SymVal Value d,a''] | a'' <- t] - | otherwise = undefined -compile i@(Op _ _ _) = return () -compile (Branch v alts) = withFreeSet $ do - (instr,brInfo) <- asks branchPos - let alignPast instr = preserve $ case brInfo instr of - (_,_,Just (registers -> regs)) -> protectFuture $ listening $ do - unProtectFuture $ loadArgs [(SymVal Value s,Just r) | (s,r) <- BM.toList regs] - free <- get - storeRegs (SB.toList free) - _ -> return mempty - 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 - code | de==0 = [] - | de > -128 && de<=128 = short++take 1 (bytes da) - | otherwise = long++take 4 (bytes da) - jmp = jmpc [0xeb] [0xe9] - start i = BC (est,pos,undefined) where (est,pos,_) = brInfo i - - case alts of - [def,null] -> do - (r,c) <- listen $ protectFuture $ do - r <- lift $ gets (lookupArgReg v . registers) - case mfilter (>=16) r of - Just r -> return r - Nothing -> unProtectFuture (loadArgs [(v,Nothing)]) >§ \[Left r] -> r - [al,al'] <- mapM alignPast [def,null] - let [_,_,p1,_,p2,_,p3] = scanl mappend (start instr) 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 - mapM_ tell codes - [def] -> do - al <- alignPast def - let [_,_,p] = scanl mappend (start instr) codes - codes = [al,jmp p (start def)] - mapM_ tell codes - [] -> tellCode [0xc3] - -compile (Bind bv Nothing) = modifyF frameF (frameAlloc defSize bv) >> return () -compile (Bind bv _) = return () -compile Noop = return () + [_,_,v] <- loadArgs [(a,Just rax),(IntVal 0,Just rdx),(a',Nothing)] + readFuture $ do + case mfilter (/=d) $ argValSym a of + Just s | isActive s -> storeRegs [rax] + _ -> return () + case v of + Left r -> op [0xf7] 7 7 r + Right v -> opi (codeFun []) [0xf7] 7 7 v + lift $ associate (if b==BMod then rdx else rax) (Just d) -ignore m = return () - +compileOp b d args@(a:a':t) | isBinOp b = + sequence_ [compileOp b d [a,a'] + | b <- repeat b + | d <- repeat d + | a <- a:repeat (SymVal Value d) + | a' <- a':t] +compileOp _ _ _ = return ()