alpha 0.9.9.5 → 0.99
raw patch · 12 files changed
+288/−200 lines, 12 files
Files
- alpha.cabal +2/−3
- src/Alpha.hs +5/−6
- src/Compile/Utils.hs +1/−1
- src/Context.hs +26/−23
- src/My/Control/Monad.hs +8/−1
- src/My/Control/Monad/RWTL.hs +17/−6
- src/My/Prelude.hs +3/−2
- src/PCode/Value.hs +1/−0
- src/Specialize.hs +25/−17
- src/Specialize/Architecture.hs +10/−2
- src/Specialize/Types.hs +2/−1
- src/Specialize/X86_64.hs +188/−138
alpha.cabal view
@@ -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-
src/Alpha.hs view
@@ -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
src/Compile/Utils.hs view
@@ -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
src/Context.hs view
@@ -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
src/My/Control/Monad.hs view
@@ -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 ()
src/My/Control/Monad/RWTL.hs view
@@ -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)
src/My/Prelude.hs view
@@ -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
src/PCode/Value.hs view
@@ -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)
src/Specialize.hs view
@@ -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 []
src/Specialize/Architecture.hs view
@@ -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
src/Specialize/Types.hs view
@@ -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
src/Specialize/X86_64.hs view
@@ -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 ()