alpha 1.0.14 → 1.0.15
raw patch · 11 files changed
+145/−416 lines, 11 files
Files
- alpha.cabal +2/−2
- src/Alpha.hs +5/−2
- src/Compile.hs +86/−56
- src/Compile/Monad.hs +31/−0
- src/Compile/State.hs +0/−111
- src/Compile/Utils.hs +0/−153
- src/ID.hs +2/−12
- src/My/Control/Monad.hs +2/−0
- src/My/Control/Monad/State.hs +11/−3
- src/My/Data/Graph.hs +0/−73
- src/Specialize/X86_64.hs +6/−4
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 1.0.14+version: 1.0.15 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,7 +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, AvlTree, COrdering, cpphs main-is: Alpha.hs- other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Format ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate+ other-modules: Alpha Compile Compile.Monad Context Context.Language Context.Types Format ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate ghc-options: -pgmP cpphs -optP --hashes -optP --cpp hs-source-dirs: src c-sources: src/formats.c
src/Alpha.hs view
@@ -170,7 +170,8 @@ ("alpha/lang" , Right $ exportAlpha callStub0 alpha_printLang), ("alpha/print-OK" , Right $ exportAlpha callStub0 alpha_printOK), ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum),- ("alpha/print-expr" , Right $ exportAlpha callStub1 alpha_printExpr)+ ("alpha/print-expr" , Right $ exportAlpha callStub1 alpha_printExpr),+ ("alpha/print-val" , Right $ exportAlpha callStub1 alpha_printVal) ] #define str(x) #x@@ -191,6 +192,8 @@ ALPHA_EXPORT(allocate,Int -> IO (Ptr())) = mallocBytes ALPHA_EXPORT(free,Ptr() -> IO ()) = free +ALPHA_EXPORT(printVal,ID -> IO ()) sym = gets (language >>> lookupSymVal sym) >>= print+ ALPHA_EXPORT(printHelp,IO()) = printHelp ALPHA_EXPORT(printOK,IO()) = putStrLn "OK" ALPHA_EXPORT(printNum,Int -> IO()) n = print (intPtrToPtr $ fromIntegral n)@@ -220,7 +223,7 @@ get = readIORef contextRef put = writeIORef contextRef -withInitialContext = withState initialContext+withInitialContext = swapping id_ initialContext initialContext = C ?settings lang jitA M.empty (fromIntegral entry) Nothing where (lang,jitA) = execState (mapM_ st initialBindings) (mempty,M.empty) where st (s,v) = do
src/Compile.hs view
@@ -1,50 +1,76 @@-{-# LANGUAGE TupleSections, ParallelListComp, NoMonomorphismRestriction #-}+{-# LANGUAGE TupleSections, ParallelListComp, NoMonomorphismRestriction, RecursiveDo, ViewPatterns #-} module Compile(compile) where -import Compile.State as CS-import Compile.Utils+import Compile.Monad import Context+import Control.Monad.Writer import Data.Either+import Data.Function import Data.Maybe import ID import My.Control.Monad import My.Control.Monad.State-import My.Data.Graph as G hiding (deleteEdge,deleteNode) import My.Data.List import My.Prelude import PCode+import qualified Data.Map as M import Syntax+import Data.Array+import My.Data.Tree -compile args ret expr = evalStateT st defaultState- where st = do- (_,(start,_)) <- compile' (fmap bindSym ret) expr- c <- simplify start >>= linearize >>= lift . uniquify args ret- return $ Code args c ret+lookupName s = lift $ gets (lookupSymName s)+getSymVal s = lift $ gets (lookupSymVal s)+newVar = lift (state createSym)+intercept m = censor (const mempty) $ listen m+m !- s = fromMaybe s $ M.lookup s m+addLocals ls = modifying locals_ $ \m -> foldr (uncurry M.insert) m ls +globVal t s locs = case M.lookup s locs of+ Just s' -> SymVal t s'+ Nothing -> SymVal GValue s+branch (IntVal (fromInteger -> n)) alts | n>=0 && n<length (tail alts) = goto (tail alts!!n)+ | otherwise = goto (head alts)+branch v alts = tell [Branch v alts] >> return NullVal+goto n = branch NullVal [n]+a ?>>= b = listen a >>= \(a,l) -> if null l || not (isBranch $ last l) then b a else return a+a ?>> b = a ?>>= const b+flattenable code = map (f . instr) code'+ where f (Branch v alts) = Branch v (map (a!) alts)+ f i = i+ (bounds,instr,nexts,_) = navigate code+ t = spanningTree 0 nexts ; code' = flatten t+ a = array bounds (zip code' [0..]) +compile args ret expr = runCompileT (compile' (fmap bindSym ret) expr)+ (M.fromList [(s,s) | bv <- maybe id (:) ret args, s <- bindSyms bv])+ >§ \(_,c) -> Code args (flattenable $ c++[Branch NullVal []]) ret+ compile' dest (Symbol sym) = do- name <- getSymName sym- let def = SymVal Value sym+ name <- lookupName sym+ locs <- gets locals+ let def = globVal Value sym locs val = fromMaybe def (IntVal $< (readConstant =<< name))- fromMaybe (nullCodeVal val) $ do- v <- dest- guard (not $ v `varEqVal` val)- return $ do n <- createNode (Instr $ set v val)- return (def,singleCode n)+ case dest of+ Just v | v/=sym -> tell [set v val] >> return def+ _ -> return val compile' dest (Group (Symbol id:args)) = do gl <- getSymVal id let compile = case gl of- Just (Axiom a) -> compileAxiom a- Just (Builtin b) -> compileBuiltin b+ Axiom a -> compileAxiom a+ Builtin b -> compileBuiltin b _ -> \d a -> compileCall d (Symbol id:a) compile dest args compile' dest (Group args) = compileCall dest args +schedule dests args = do+ (vals,code) <- unzip $< sequence [intercept $ compile' dest arg | dest <- dests | arg <- args]+ mapM_ tell (reverse $ sortBy (compare`on`length) code)+ return vals+ compileBy op dest args = do- (vars,code) <- unzip $< mapM (compile' Nothing) args+ vals <- schedule (repeat Nothing) args dest <- maybe newVar return dest- n <- createNode (Instr $ op dest vars)- sequence_ [createEdge TimeDep n' n | (_,l) <- code, n' <- l]- return (SymVal Value dest,(n:concatMap fst code,[n]))+ tell [op dest vals]+ return (SymVal Value dest) compileBuiltin _ dest [] = compileValue dest (IntVal 0) compileBuiltin b dest args = compileBy (Op b) dest args@@ -52,55 +78,62 @@ compileAxiom XAlter _ forms = do let (vars,exprs) = partitionEithers $ zipWith ($) (cycle [Left,Right]) forms- codes <- sequence [compile' (Just v) e | Symbol v <- vars | e <- exprs]- let (starts,ends) = unzip $ map snd codes- return (NullVal,(concat starts,concat ends))+ locs <- gets locals+ let assocs = [(v,locs!-v) | Symbol v <- vars]+ schedule (map (Just . snd) assocs) exprs+ addLocals assocs+ return NullVal compileAxiom XBind _ args = case args of [bVars] -> doBind bVars Nothing [bVars,expr] -> do v <- newVar- compile' (Just v) expr *>> doBind bVars (Just v)+ compile' (Just v) expr+ doBind bVars (Just v) where doBind bVars val = do bnd <- bindFromSyntax bVars- n <- createNode (Instr $ PCode.Bind bnd val)- return (NullVal,singleCode n)+ bnd' <- localizeBV bnd+ tell [PCode.Bind bnd' val]+ return NullVal+ localizeBV (BindVar s sz pad subs) = do+ s' <- newVar+ addLocals [(s,s')]+ subs' <- mapM (\(bv,n) -> liftM (,n) (localizeBV bv)) subs+ return (BindVar s' sz pad subs') -compileAxiom XDo dest [] = nullCode+compileAxiom XDo dest [] = return NullVal compileAxiom XDo dest forms = do let cs = reverse $ zipWith compile' (dest:repeat Nothing) (reverse forms)- foldr1 (*>>) cs+ last $< sequence cs compileAxiom XChoose dest (cond:forms) = do- start <- mkNoop ; end <- mkNoop- alts <- replicateM (length forms) mkNoop v <- maybe newVar return dest- let dest = Just v-- withTopInfo (start,alts,end,dest) $ do- return (NullVal,singleCode start)- *>> compile' Nothing cond- *>>= \cv -> do- let code = zipWith compile' (repeat dest) forms- fun alt code = return (NullVal,singleCode alt) *>> code *>> makeBranch NullVal [end]- sequence_ $ zipWith fun alts code- makeBranch cv alts-- return (SymVal Value v,([start],[end]))+ + rec+ pushInfo (start,alts,end,dest)+ start <- getPos+ condVal <- compile' Nothing cond+ branch condVal alts+ let compileAlt alt = saving locals_ $ getPos ->> (compile' (Just v) alt ?>> goto end)+ alts <- mapM compileAlt forms+ end <- getPos+ popInfo+ + return (SymVal Value v) -compileAxiom XReturn dest [arg] = withInfo $ \(_,_,end,dest) -> compile' dest arg *>> makeBranch NullVal [end]+compileAxiom XReturn _ [arg] = withInfo $ \(_,_,end,dest) -> compile' dest arg ?>> goto end -compileAxiom XRestart _ [] = withInfo $ \(start,_,_,_) -> makeBackBranch NullVal [start]+compileAxiom XRestart _ [] = withInfo $ \(start,_,_,_) -> goto start compileAxiom XRestart _ [arg] = withInfo $ \(_,alts,_,_) ->- compile' Nothing arg *>>= \v -> makeBackBranch v alts+ compile' Nothing arg ?>>= \v -> branch v alts -compileAxiom XAddr dest [Symbol s] = compileValue dest (SymVal Address s)+compileAxiom XAddr dest [Symbol s] = gets locals >>= compileValue dest . globVal Address s compileAxiom XSize dest [Symbol s] = compileValue dest (SymVal Size s) compileAxiom XID dest [Symbol s] = compileValue dest (SymVal SymID s) compileAxiom XVerb dest [Group (name:args),expr] = do bv@BindVar { bindSym = sym } <- bindFromSyntax name ret <- case bindSubs bv of- [] -> newVar >>= \ret -> return bv { bindSym = ret }+ [] -> newVar >§ \ret -> bv { bindSym = ret } (h,_):_ -> return h code <- compileExpr args (Just ret) expr lift $ modify $ exportSymVal sym (Verb code)@@ -124,15 +157,13 @@ args <- mapM bindFromSyntax args code <- lift $ compile args ret expr return code-compileValue dest val = do- c <- singleCode $< case dest of- Just v -> createNode (Instr $ set v val)- Nothing -> mkNoop- return (val,c)+compileValue dest val = (>>return val) $ case dest of+ Just v -> tell [set v val]+ Nothing -> return () bindFromSyntax (Symbol v) = return $ symBind v bindFromSyntax (Group (Symbol v:t)) = do- let fun (ns,l) (Symbol v) = getSymName v >>= \s ->+ let fun (ns,l) (Symbol v) = lookupName v >>= \s -> maybe (fun' ns l (Symbol v)) (\n -> return (n:ns,l)) (readConstant =<< s) fun (ns,l) e = fun' ns l e fun' ns l e = do@@ -145,4 +176,3 @@ (a,b) <+> (a',b') = (a+a',b+b') return $ BindVar v size pad subs bindFromSyntax s = error $ "Invalid shape for bindVar : "++show s-
+ src/Compile/Monad.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, NoMonomorphismRestriction #-}+module Compile.Monad where++import My.Control.Monad.State+import My.Control.Monad.WriterAcc+import ID+import PCode.Instruction+import Data.Map++data CompileState = CS {+ infoStack :: [(Int,[Int],Int,Maybe ID)],+ locals :: Map ID ID+ }+infoStack_ = View (infoStack,\s cs -> cs { infoStack = s })+locals_ = View (locals,\s cs -> cs { locals = s })++newtype CompileT m a = CM { runCM :: StateT CompileState (WriterAccT [Instruction] (Sum Int) m) a }+ deriving (Monad,MonadFix,MonadState CompileState,MonadWriter [Instruction])+instance MonadTrans CompileT where+ lift = CM . lift . lift++getPos = CM (liftM getSum (lift getAcc))+runCompileT (CM m) locals = runWriterAccT (evalStateT m (CS [] locals))++pushInfo = modifying infoStack_ . (:)+popInfo = viewState infoStack_ (\l -> case l of+ (h:t) -> (h,t)+ [] -> error "Invalid use of Axioms <- or -> outside of a choose expression")+topInfo = getting (infoStack_ >>> f_ head)+withInfo f = popInfo >>= \i -> f i >>= \ret -> pushInfo i >> return ret+
− src/Compile/State.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction, ViewPatterns #-}-module Compile.State(- module My.Data.Graph,- CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..),- depGraph_,infoStack_,- newVar,- pushInfo,popInfo,topInfo,withInfo,withTopInfo,- defaultState,- getSymName,getSymVal,- singleCode,- isBackEdge,- getNodeList,getContext,- createEdge,deleteEdge,- createNode,deleteNode,- nullCode,nullCodeVal,- makeTimeDep,makeBranch,makeBackBranch,mkNoop,- (*>>=),(*>>)- )- where--import Control.Category ((>>>))--import PCode-import My.Control.Monad.State-import My.Control.Monad-import ID-import My.Data.Graph hiding (deleteEdge,deleteNode,getContext,empty)-import Context as C-import qualified My.Data.Graph as G-import qualified Data.Map as M--deriving instance Eq Instruction-deriving instance Eq PCode.Value-deriving instance Eq BindVar--data BranchType = Forward | Backward- deriving (Show,Eq)-data EdgeData = BranchAlt BranchType Int- | TimeDep- deriving (Show,Eq)-data NodeData = Instr Instruction- | BrPart PCode.Value- deriving Eq -type CaseInfo = (Node,[Node],Node,Maybe ID)--data CompileState = CS {- infoStack :: [CaseInfo],- depGraph :: Graph EdgeData NodeData- }- deriving Show--depGraph_ = View (depGraph,(\g cs -> cs { depGraph = g }))-infoStack_ = View (infoStack,(\l cs -> cs { infoStack = l }))--defaultState = CS [] G.empty-singleCode n = ([n],[n])-isBackEdge (_,BranchAlt Backward _) = True-isBackEdge _ = False--getSymName = lift . gets . C.lookupSymName-getSymVal s = lift $ getting (vals_ >>> f_ (M.lookup s))-newVar = lift $ state createSym--pushInfo = modifying infoStack_ . (:)-popInfo = viewState infoStack_ (\l -> case l of- (h:t) -> (h,t)- [] -> error "Invalid use of Axioms <- or -> outside of a choose expression")-topInfo = getting (infoStack_ >>> f_ head)-withTopInfo i x = pushInfo i >> x >>= \v -> popInfo >> return v-withInfo f = popInfo >>= \i -> f i >>= \ret -> pushInfo i >> return ret--mkNoop = createNode (Instr Noop)-nullCode = nullCodeVal NullVal-nullCodeVal v = mkNoop >>= \n -> return (v,singleCode n)--getNodeList = getting (depGraph_ >>> f_ nodeList)-getContext n = getting (depGraph_ >>> f_ (G.getContext n))--createNode x = viewState depGraph_ (G.insertNode x)-deleteNode n = modifying depGraph_ (G.deleteNode n)-modifyNode n f = modifying depGraph_ (G.modifyNode n f)-createEdge x n1 n2 = modifying depGraph_ (G.insertEdge x n1 n2)-deleteEdge n1 n2 = modifying depGraph_ (G.deleteEdge n1 n2)--makeTimeDep a b = do- (v,(_in,_out)) <- a- case _out of- [] -> return (NullVal,(_in,_out))- _ -> do- (v,(_in',_out')) <- b v- sequence_ [createEdge TimeDep n n' | n <- _out,n' <- _in']- return (v,(_in,_out'))-(*>>=) = makeTimeDep-a *>> b = a *>>= const b--infixr 1 *>>= -infixr 1 *>> --makeBranch = makeBranch' Forward-makeBackBranch = makeBranch' Backward-makeBranch' typ val alts = do- br <- createNode (BrPart val)- let makeAlt n = createEdge (BranchAlt typ n) br- case val of- IntVal (fromIntegral -> i) -> makeAlt 0 (if i+1<length alts then tail alts!!i else head alts)- _ -> sequence_ $ zipWith makeAlt [0..] alts - return (NullVal,([br],[]))--instance Show NodeData where- show (Instr i) = show i- show (BrPart v) = "case "++show v
− src/Compile/Utils.hs
@@ -1,153 +0,0 @@-{-# LANGUAGE TupleSections, ViewPatterns, NoMonomorphismRestriction #-}-module Compile.Utils where--import Control.Category ((>>>))-import Compile.State as CS-import Context.Language-import Data.Array-import Data.Function-import Data.Maybe-import qualified Data.Map as M-import qualified Data.Set as S-import My.Control.Monad-import My.Control.Monad.State-import qualified My.Data.Graph as G-import My.Data.List-import My.Data.Tree-import My.Prelude-import PCode-import Syntax -import Translate--flattenable code = map (f . instr) code'- where f (Branch v alts) = Branch v (map (a!) alts)- f i = i- (bounds,instr,nexts,_) = navigate code- t = spanningTree 0 nexts ; code' = flatten t- a = array bounds (zip code' [0..])--uniquify a r [] = uniquify a r [Branch NullVal []]-uniquify args ret code = do- ret <- descendM uniq (M.fromList $ zip syms syms) $ spanningTree 0 nexts- return (flatten ret)- where syms = concatMap bindSyms $ maybe id (:) ret args- (_,instr,nexts,_) = navigate $ flattenable 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')- uniq i m = return (translate (translateBy m) `on_` fst_ $ withLocals m $ instr i)- localVal m (SymVal t s) | (t==Value || t==Address) && not (M.member s m) = SymVal GValue s- localVal m v = v- translateBy m s = fromMaybe s $ M.lookup s m- withLocals m (Op b v vs) = (Op b v (map (localVal m) vs),M.insertWith (flip const) 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- oldDep <- getting depGraph_ ; purgeAll ; newDep <- getting depGraph_- return $ concatMap (newStart oldDep newDep) start- where - purgeAll = do- mapM_ (purgeNode isNoop) =<< getNodeList- mapM_ (purgeNode isEmptyBranch) =<< getNodeList- purgeNode p n = do- c <- getContext n - if p c then remove (n,c) else return ()- isNoop c = tag c==Instr Noop- isEmptyBranch c = case tag c of - BrPart _ -> not (null o) && all p i && all p' o- _ -> False- where (i,o) = edges c - p (_,BranchAlt _ _) = True ; p _ = False- p' (_,BranchAlt _ 0) = True ; p' _ = False- remove (n',c) = do- let - (lies,loes) = edges c- least Forward Forward = Forward - least _ _ = Backward - mergeEdge (BranchAlt t x) (BranchAlt t' _) = BranchAlt (least t t') x- mergeEdge TimeDep b = b- mergeEdge e t = mergeEdge t e- sequence_ [deleteEdge n n' | (n ,_) <- lies ]- sequence_ [deleteEdge n' n'' | (n'',_) <- loes ]- sequence_ [createEdge (mergeEdge t t') n n'' | (n ,t) <- lies, (n'',t') <- loes ]- deleteNode n'- newStart old new = newStart- where - newStart n = fromJust $ (lookupContext n new >> return [n])- `mplus` (lookupContext n old >§ \c -> concat [newStart n | (n,_) <- outEdges c])- `mplus` return []--data ANode = ANode {- weight :: Int,- erNum :: Int,- instr :: NodeData- }- deriving Show-linearize start = getting (depGraph_ >>> f_ (linearize' start))-linearize' start depG = instrs- where - aG = annotate depG- getContext n = G.getContext n aG- withContext n = (n,getContext n)- (<#) = ((<) `on` (weight . tag))- - isBrPart (instr . tag . getContext -> BrPart _) = True- isBrPart _ = False- instrMap = M.fromList $ zip instrs (sums (map (length . getInstr) instrs))- where instrs = concat blocks- instrs = concatMap (concatMap getInstr) blocks -- getInstr (getContext -> c) = case tag c of- ANode { instr = BrPart v } -> [Branch v $ map branch (classesBy (===) oes)]- where branch ns = minimum $ catMaybes [M.lookup n instrMap | (n,_) <- ns]- (===) = (==)`on`snd- ANode { instr = Instr i } -> i : if null oes then [Branch NullVal []] else []- where oes = outEdges c-- selectHeads l = [n | (n,c) <- l, weight (tag c)==1]- startHeads = selectHeads $ map withContext $ nub start- heads = startHeads : deleteBy headsEq startHeads heads- where eq n1 n2 = if n1`elem`start then n2`elem`start else c'- where c' = n2 `elem` [n | (n,e') <- outEdges $ getContext prev, e==e']- (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG)- $ find isBackEdge $ inEdges $ getContext n1- headsEq a b = sort a==sort b- heads = classesBy eq $ selectHeads $ nodeListFull aG- tails = map (S.toList . S.unions) $ classesBy share $ map (S.fromList . concatMap saturate) heads- where share s s' = not $ S.null (s `S.intersection` s')- saturate n = if null nexts then [n] else concatMap saturate nexts- where nexts = [n' | let c = getContext n - , (n',c') <- map withContext $ nextNodes c- , c <# c']-- - blocks = map blockFromTails tails- blockFromTails tails = evalState (concat $< mapM makeBlock tails) S.empty- where - visited n = gets (S.member n) ; visit n = modify (S.insert n)- - makeBlock n = ifM (visited n) (return []) $ do - prevs <- mapM makeBlock (getPrevs n)- visit n- return $ concat prevs ++ [n]- getPrevs n = map fst $ sortBy cmp $ filter p $ map withContext $ prevNodes ctx- where cmp = compare `on` (erNum . tag . snd)- p (_,c) = c <# ctx- ctx = getContext n--annotate depG = newdepG- where - newdepG = mapNodes depCalc depG- depCalc (depCalc' -> (a,b)) i = ANode a b i- depCalc' (flip G.getContext depG -> c)- | any isBackEdge <||> null $ inEdges c = (1,1)- | otherwise = (1+maximum a, maximum $ zipWith (+) [0..] (reverse $ sort b))- where (a,b) = unzip [(weight t,erNum t) - | n' <- prevNodes c- , let t = tag $ G.getContext n' newdepG]- - maximum = foldl max 0-
src/ID.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module ID where newtype ID = ID Int- deriving (Ord,Eq)+ deriving (Ord,Eq,Enum,Num) newtype Range a = Range (a,a) singleRange i = Range (i,i)@@ -14,17 +15,6 @@ | b'<=a = GT | otherwise = EQ -instance Enum ID where- toEnum = ID- fromEnum (ID i) = i instance Show ID where show (ID i) = "x"++show i-instance Num ID where- ID a + ID b = ID (a+b)- ID a - ID b = ID (a-b)- ID a * ID b = ID (a*b)- negate = undefined- abs = undefined- signum = undefined- fromInteger n = ID $ fromInteger n
src/My/Control/Monad.hs view
@@ -2,6 +2,7 @@ module My.Control.Monad (module Control.Monad ,($<),(>$),(>$<) ,(§),(§<),(>§),(>§<)+ ,(->>) ,(<&&>),(<||>) ,ifM,findM,prog1 ,doNothing) where@@ -32,6 +33,7 @@ infixr 3 <||> prog1 a b = a >>= \x -> b >> return x+(->>) = prog1 findM p l = foldr fun (return Nothing) l where fun x ret = ifM (p x) (return $ Just x) ret
src/My/Control/Monad/State.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE TupleSections, NoMonomorphismRestriction #-} module My.Control.Monad.State(module Control.Monad.State ,View(..)- ,viewState,viewing,modifying,getting,putting+ ,viewState+ ,viewing,modifying,getting,putting+ ,swappingWith,swapping+ ,saving ,fst_,snd_,id_,f_,on_- ,withState) where+ ,(>>>),(<<<)) where +import My.Control.Monad import Prelude hiding ((.),id) import Control.Monad.State hiding (withState) import Control.Category@@ -27,5 +31,9 @@ f `on_` View (v,v') = \x -> v' (f (v x)) x -withState s mx = get >>= \v -> put s >> mx >>= \x -> put v >> return x+saving v m = getting v >>= \x -> m ->> putting v x++swappingWith v f m = saving v (modifying v f >> m)+swapping v s = swappingWith v (const s)+
− src/My/Data/Graph.hs
@@ -1,73 +0,0 @@-module My.Data.Graph( - Graph,Node(..),- - empty,- lookupContext,getContext,- insertNode,deleteNode,modifyNode,- insertEdge,deleteEdge,- - modifyInEdges,modifyOutEdges,- tag,inEdges,outEdges,edges,- nextNodes,prevNodes,- - nodeList,nodeListFull,- - mapNodes- )- where--import qualified Data.Map as M-import Data.List-import Data.Maybe--type Node = Int-data Context e n = Context { - nodeTag :: n, - nodeInEdges :: M.Map Node e, - nodeOutEdges :: M.Map Node e- } deriving Show-data Graph e n = Graph {- nbNodes :: Int,- graphNodes :: M.Map Node (Context e n)- }- -empty = Graph 0 M.empty--lookupContext n (Graph _ nds) = M.lookup n nds-getContext n g = fromMaybe (error $ "No node "++show n++" in graph "++show g) $ lookupContext n g--insertNode x (Graph n nds) = (n,Graph (n+1) (M.insert n (Context x M.empty M.empty) nds))-deleteNode nd (Graph n nds) = Graph n (M.delete nd nds)-modifyNode nd f (Graph n nds) = Graph n (M.adjust (\(Context t i o) -> Context (f t) i o) nd nds)--insertEdge x n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.insert n1 x)) n2 $- M.adjust (modifyOutEdges (M.insert n2 x)) n1 nds) -deleteEdge n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.delete n1)) n2 $- M.adjust (modifyOutEdges (M.delete n2)) n1 nds)--modifyInEdges f c = c { nodeInEdges = f $ nodeInEdges c }-modifyOutEdges f c = c { nodeOutEdges = f $ nodeOutEdges c }--tag = nodeTag-inEdges = M.toList . nodeInEdges-outEdges = M.toList . nodeOutEdges-edges c = (inEdges c,outEdges c)--nextNodes = map fst . outEdges-prevNodes = map fst . inEdges--nodeList = map fst . nodeListFull-nodeListFull = M.toList . graphNodes--mapNodes f (Graph n nds) = Graph n (M.mapWithKey (\n (Context t ie oe) -> Context (f n t) ie oe) nds)--instance (Show n,Show e) => Show (Graph e n) where- show (Graph _ nds) = intercalate "\n" showNodes- where showNodes = map showNode $ M.toList nds- showNode (n,Context nd ie oe) = - show n++": "++show nd++"\n "++- intercalate "\n " (map showNEdge (M.toList oe)- ++ map showREdge (M.toList ie))- where showNEdge (n',e) = "--"++show e++"--> "++show n'- showREdge (n',e) = "<--"++show e++"-- "++show n'-
src/Specialize/X86_64.hs view
@@ -52,8 +52,9 @@ varSize s = fromMaybe defSize (M.lookup s $ sizes ?info) argSize = maybe defSize varSize . valSym verbAddress = let (me,addrs) = envInfo ?info in addrs me-instrAddress i = let (_,addrs) = branchPos ?info ; (e,s,_) = addrs i in (e,s) -instrPast i = let (_,addrs) = branchPos ?info ; (_,_,p) = addrs i in p +instrInfo = snd (branchPos ?info)+instrAddress i = let (e,s,_) = instrInfo i in (e,s) +instrPast i = let (_,_,p) = instrInfo i in p thisInstr = fst $ branchPos ?info frameAddr s = viewState frame_ (withAddr defSize s)@@ -196,8 +197,9 @@ compile i = ask >>= \info -> do let ?info = info (_,BC (e',s',_)) <- listen (storeFlags (branchSym i)) - let ?info = info { branchPos = (thisInstr,- \i -> let (e,s,p) = snd (branchPos ?info) i in (e+e',s+s',p)) }+ let getPast i | i==thisInstr = let (e,s,p) = instrInfo i in (e+e',s+s',p)+ | otherwise = instrInfo i+ let ?info = info { branchPos = (thisInstr,getPast) } compile' i modifying locations_ (R.filterDom isActive) where branchSym (Branch (SymVal Value s) _) = Just s