├── Choco.cabal ├── Readme ├── Setup.hs ├── lamlib ├── array.cmm ├── atan.cmm ├── floor.cmm ├── int_float.cmm ├── io.cmm └── sincos.cmm ├── lib.s ├── src ├── ArrayOpt.hs ├── AsmGen.hs ├── CLamSyn.hs ├── Choco.hs ├── Closure.hs ├── Closure_back.hs ├── CmmGen.hs ├── CmmSyn.hs ├── Coloring.hs ├── Comballoc.hs ├── Common.hs ├── Const.hs ├── Contract.hs ├── Driver.hs ├── ElimLet.hs ├── Error.hs ├── Flags.hs ├── Hoisting.hs ├── Id.hs ├── Interf.hs ├── LamGen.hs ├── LamOpt.hs ├── LamSyn.hs ├── Lexer.hs ├── Lexer.x ├── LibLex.hs ├── LibLex.x ├── LibParse.y ├── Libraries.hs ├── Linearize.hs ├── Linearize_back.hs ├── Liveness.hs ├── LocalCSE.hs ├── Log.hs ├── Mach.hs ├── Main.hs ├── McSyn.hs ├── MemAnal.hs ├── Outputable.hs ├── Panic.hs ├── Parser.hs ├── Parser.y ├── Primitive.hs ├── Primitive_NoCmmLib.hs ├── Primitive_WithCmmLib.hs ├── Reg.hs ├── RegM.hs ├── Reload.hs ├── Schedular.hs ├── Schedular_back.hs ├── Selection.hs ├── Spill.hs ├── Split.hs ├── SrcLoc.hs ├── TcSyn.hs ├── Types.hs ├── Typing.hs ├── Unpoly.hs ├── Unpoly_back.hs ├── Util.hs └── Var.hs ├── testcodes ├── arraytest1.as ├── arraytest1.ml ├── arraytest2-noopt.as ├── arraytest2.as ├── arraytest2.ml ├── arraytest3.as ├── arraytest3.ml ├── fib.as ├── fib.ml ├── float_fib.as ├── float_fib.ml ├── recur.as ├── recur.ml ├── tuple_array.as ├── tuple_array.ml ├── tupletest1.as ├── tupletest1.ml ├── tupletest2.as └── tupletest2.ml └── tsubaki ├── Arch.hs ├── Emit.hs ├── Proc.hs └── Scheduling.hs /Choco.cabal: -------------------------------------------------------------------------------- 1 | Name: Choco 2 | Version: 0.1 3 | License: GPL 4 | Author: Nakamura Koichi 5 | Category: Testing 6 | Build-Depends: base,mtl,parsec,HUnit,array,containers,pretty,old-time, process 7 | Synopsis: The MinCaml compiler written in Haskell 8 | 9 | Executable: choco 10 | Main-Is: Main.hs 11 | Hs-Source-Dirs: src tsubaki 12 | Other-Modules: Lexer Parser 13 | -------------------------------------------------------------------------------- /Readme: -------------------------------------------------------------------------------- 1 | Dependencies : GHC, Alex, Happy, HUnit 2 | 3 | #=== build ===# 4 | $ runhaskell Setup configure 5 | $ runhaskell Setup build 6 | 7 | #=== run tests ===# 8 | $ runhaskell Setup test 9 | 10 | #=== clean ===# 11 | $ runhaskell Setup clean 12 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Distribution.Simple 4 | import System.Exit 5 | import System.Cmd 6 | import System.Directory 7 | import Control.Exception 8 | import Control.Monad 9 | 10 | main = defaultMain 11 | {- 12 | main = defaultMainWithHooks $ 13 | defaultUserHooks { 14 | runTests = runTestScript 15 | } 16 | 17 | withCurrentDirectory path f = do 18 | cur <- getCurrentDirectory 19 | setCurrentDirectory path 20 | finally f (setCurrentDirectory cur) 21 | 22 | runTestScript _ _ _ _ = do 23 | system "runghc Setup configure --prefix=test" 24 | code <- system "runghc Setup build" 25 | 26 | case code of 27 | ExitFailure _ -> do 28 | putStrLn "ERROR : Compilation failed" 29 | exitWith (ExitFailure 1) 30 | _ -> do return () 31 | 32 | system "runghc Setup copy" 33 | withCurrentDirectory "test" (system "bin/runtest") 34 | return () 35 | -} 36 | -------------------------------------------------------------------------------- /lamlib/array.cmm: -------------------------------------------------------------------------------- 1 | function lib_create_array (num value) 2 | (let_const header (alloc num) 3 | (for i in 0..num 4 | store (adds header i) value 5 | ) 6 | header); 7 | 8 | function lib_create_big_array (size num e) 9 | (let_const header (alloc 0) 10 | for i in 0..num 11 | (let_const ptr (alloc size) 12 | for j in 0..size 13 | ( 14 | store (add ptr j) (load (add e j)) 15 | ) 16 | ) 17 | header 18 | ); 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /lamlib/atan.cmm: -------------------------------------------------------------------------------- 1 | function myatan_k (x) 2 | (let_const z (fmul x x) 3 | let_const w (fmul z z) 4 | (fadd 5 | (fmul z (fadd 0x3eaaaaaa (fmul w (fadd 0x3e124925 (fmul w (fadd 0x3dba2e6e (fmul w (fadd 0x3d886b35 (fmul w (fadd 0x3d4bda59 (fmul w 0x3c8569d7))))))))))) 6 | (fmul w (fadd 0xbe4ccccd (fmul w (fadd 0xbde38e38 (fmul w (fadd 0xbd9d8795 (fmul w (fadd 0xbd6ef16b (fmul w 0xbd15a221)))))))))) 7 | ); 8 | 9 | function myatan (x) 10 | (let_const ix (fabs x) 11 | if (ix >= 0x50800000) 12 | (if (x <. 0.0) 0xbfc90fdb 0x3fc90fdb) 13 | ( 14 | if (ix < 0x31000000) x 15 | ( 16 | if (ix < 0x3ee00000) (fsub x (fmul x (call myatan_k x))) 17 | ( 18 | let nx (fabs x) 19 | if (ix < 0x3f300000) 20 | ((assign nx (fdiv (fsub (fmul 2.0 nx) 1.0) (fadd 2.0 nx))) 21 | (let_const z (fsub 0x3eed6338 (fsub (fsub (fmul nx (call myatan_k nx)) 0x31ac3769) nx))) 22 | (if (hx < 0) (fneg z) z)) 23 | ( 24 | if (ix < 0x3f980000) 25 | ((assign nx (fdiv (fsub nx 1.0) (fadd nx 1.0))) 26 | (let_const z (fsub 0x3f490fda (fsub (fsub (fmul nx (call myatan_k nx)) 0x33222168) nx))) 27 | (if (hx < 0) (fneg z) z)) 28 | ( 29 | if (ix < 0x401c0000) 30 | ((assign nx (fdiv (fsub x 1.5) (fadd 1.0 (fmul 1.5 nx)))) 31 | (let_const z (fsub 0x3f7b985e (fsub (fsub (fmul nx (call myatan_k nx)) 0x33140fb4) nx))) 32 | (if (hx < 0) (fneg z) z)) 33 | ( 34 | (assign nx (fneg (fdiv 1.0 x))) 35 | (let_const z (fsub 0x3fc90fda (fsub (fsub (fmul nx (call myatan_k nx)) 0x33a22168) nx))) 36 | (if (hx < 0) (fneg z) z) 37 | )))))) 38 | ); 39 | 40 | -------------------------------------------------------------------------------- /lamlib/floor.cmm: -------------------------------------------------------------------------------- 1 | function lib_floor (f) 2 | (let_const a (call lib_float_int (call lib_int_of_float f)) 3 | if (f <. 0.0) 4 | (if (f ==. a) a (fsub a 1.0)) a 5 | ); 6 | -------------------------------------------------------------------------------- /lamlib/int_float.cmm: -------------------------------------------------------------------------------- 1 | function lib_float_of_int (i) 2 | (let_const j (subs i (fabs i)) 3 | let_const k (if (i > 0) i (subs 0 i)) 4 | let_const flt8388608 0x4b000000 5 | let_const l (fsub (adds k flt8388608) flt8388608) 6 | if (k > 0x00800000) 0 (adds j l) 7 | ); 8 | 9 | function lib_int_of_float (f) 10 | (let_const g (fabs f) 11 | let_const flt8388608 0x4b000000 12 | if (g > flt8388608) 0 13 | (let_const h (subs (fadd g flt8388608) flt8388608) 14 | if (f <= 0) (subs 0 h) h) 15 | ); 16 | 17 | -------------------------------------------------------------------------------- /lamlib/io.cmm: -------------------------------------------------------------------------------- 1 | function lib_read () 2 | (call lib_read_sub 4 0); 3 | 4 | function lib_read_sub (index value) 5 | (if (index == 0) value 6 | (call lib_read_sub (subi index 1) (adds (slliu value 8) (call get_func)))); 7 | 8 | function get_func () 9 | (let_const a (get) 10 | if (a < 0) (call get_func) a); 11 | 12 | 13 | -------------------------------------------------------------------------------- /lamlib/sincos.cmm: -------------------------------------------------------------------------------- 1 | function k_sin (x) 2 | (let_const y (fmul x x) 3 | (fmul x (fadd 1.0 (fmul y (fadd 0xbe2aaaab (fmul y (fadd 0x3c088889 (fmul y (fadd 0xb9500d01 (fmul y (fadd 0x3638ef1b (fmul y (fadd 0xb2d72f34 (fmul y 0x2f2ec9d3)))))))))))))); 4 | 5 | function k_cos (x) 6 | (let_const y (fmul x x) 7 | (fadd 1.0 (fmul y (fadd 0xbf000000 (fmul y (fadd 0x3d2aaaab (fmul y (fadd 0xbab60b61 (fmul y (fadd 0x37d00d01 (fmul y (fadd 0xb493f27c (fmul y (fadd 0x310f74f6 (fmul y 0xad47d74e))))))))))))))); 8 | 9 | function reduction (x) 10 | ( 11 | let_const hpi 0x3fc90fdb 12 | let_const qpi 0x3f490fdb 13 | let t (fabs x) 14 | let r 0 15 | (while (t >. qpi) ( 16 | (assign t (fsub t hpi)) 17 | (assign r (if (r < 3) (addiu r 1) 0)) 18 | )) 19 | (t, r) 20 | ); 21 | 22 | 23 | function lib_cos (a) 24 | ( 25 | let_const (t, r) (call reduction a) 26 | if (r == 0) 27 | (call k_cos t) 28 | (if (r == 1) 29 | (fneg (call k_sin t)) 30 | (if (r == 2) 31 | (fneg (call k_cos t)) 32 | (call k_sin t))) 33 | ); 34 | 35 | function lib_sin (a) 36 | ( 37 | let_const (t, r) (call reduction a) 38 | if (r == 0) 39 | (call k_sin t) 40 | (if (r == 1) 41 | (call k_cos t) 42 | (if (r == 2) 43 | (fneg (call k_sin t)) 44 | (fneg (call k_cos t)))) 45 | ); 46 | 47 | -------------------------------------------------------------------------------- /src/ArrayOpt.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module ArrayOpt ( 7 | arrayOpt 8 | ) where 9 | 10 | import Choco 11 | import Const 12 | import LamSyn 13 | import Outputable 14 | import Var 15 | import Types 16 | 17 | import Control.Monad.State 18 | import qualified Data.Set as S 19 | 20 | 21 | simplif :: Lambda -> ChocoM Lambda 22 | simplif lam = case lam of 23 | Lvar _ -> return lam 24 | Llit _ -> return lam 25 | Lapp f args p -> do 26 | f' <- simplif f 27 | args' <- mapM simplif args 28 | return $ Lapp f' args' p 29 | 30 | Lfun args body -> do 31 | body' <- simplif body 32 | return $ Lfun args body' 33 | 34 | Llet Strict (ary, Lprim PcreateArray args) body -> do 35 | args' <- mapM simplif args 36 | case head args' of 37 | Llit (IntC n) -> do 38 | ids <- replicateM n newUniq 39 | let names = map (\i -> var_name ary ++ show i) [0..] 40 | let vars = zipWith 41 | (\i n -> mkVar n i (var_type ary) (isGlobal ary)) ids names 42 | case eliminateArray ary vars body of 43 | Just body' | isSimpleArgument (args' !! 1) 44 | -> do 45 | putLog (text "\tchange array" <+> ppr ary <+> text "to variable(s)") 46 | body'' <- simplif body' 47 | return $ foldr 48 | (\v cont -> Llet Variable (v, args'!!1) cont) 49 | body'' vars 50 | Just body' -> do 51 | putLog (text "\tchange array" <+> ppr ary <+> text "to variable(s)") 52 | v' <- copyVar ary 53 | body'' <- simplif body' 54 | return$ Llet Strict (v', args' !! 1) $ 55 | foldr (\v cont -> Llet Variable (v, Lvar v') cont) 56 | body'' vars 57 | Nothing -> do 58 | body' <- simplif body 59 | return $ Llet Strict (ary, Lprim PcreateArray args') body' 60 | _ -> do 61 | body' <- simplif body 62 | return $ Llet Strict (ary, Lprim PcreateArray args') body' 63 | Llet str (v, e) cont -> do 64 | e' <- simplif e 65 | cont' <- simplif cont 66 | return $ Llet str (v, e') cont' 67 | Lletrec (v, e) cont -> do 68 | e' <- simplif e 69 | cont' <- simplif cont 70 | return $ Lletrec (v, e') cont' 71 | Lprim p args -> do 72 | args' <- mapM simplif args 73 | return $ Lprim p args' 74 | Lcond e1 e2 e3 -> do 75 | e1' <- simplif e1 76 | e2' <- simplif e2 77 | e3' <- simplif e3 78 | return $ Lcond e1' e2' e3' 79 | Lseq e1 e2 -> do 80 | e1' <- simplif e1 81 | e2' <- simplif e2 82 | return $ Lseq e1' e2' 83 | Lwhile e1 e2 -> do 84 | e1' <- simplif e1 85 | e2' <- simplif e2 86 | return $ Lwhile e1' e2' 87 | Lfor v e1 e2 e3 -> do 88 | e1' <- simplif e1 89 | e2' <- simplif e2 90 | e3' <- simplif e3 91 | return $ Lfor v e1' e2' e3' 92 | Lassign v e -> do 93 | e' <- simplif e 94 | return $ Lassign v e' 95 | 96 | eliminateArray :: Var -> [Var] -> Lambda -> Maybe Lambda 97 | eliminateArray ary elems lam = case lam of 98 | Lvar v | v == ary -> Nothing 99 | | otherwise -> return $ Lvar v 100 | Llit c -> return $ Llit c 101 | Lapp f args p -> do 102 | f' <- eliminateArray ary elems f 103 | args' <- mapM (eliminateArray ary elems) args 104 | return $ Lapp f' args' p 105 | Lfun params body 106 | | isGlobal ary -> do 107 | body' <- eliminateArray ary elems body 108 | return $ Lfun params body' 109 | | ary `S.member` (freeVars lam) -> Nothing 110 | | otherwise -> return lam 111 | Llet str (v, e1) e2 -> do 112 | e1' <- eliminateArray ary elems e1 113 | e2' <- eliminateArray ary elems e2 114 | return $ Llet str (v, e1') e2' 115 | Lletrec (v, e1) e2 -> do 116 | e1' <- eliminateArray ary elems e1 117 | e2' <- eliminateArray ary elems e2 118 | return $ Lletrec (v, e1') e2' 119 | Lprim ParraySet [Lvar v, Llit (IntC n), e] | v == ary 120 | -> do e' <- eliminateArray ary elems e 121 | return $ Lassign (elems!!n) e' 122 | Lprim ParrayRef [Lvar v, Llit (IntC n)] | v == ary 123 | -> return $ Lvar (elems!!n) 124 | Lprim p args -> do 125 | args' <- mapM (eliminateArray ary elems) args 126 | return $ Lprim p args' 127 | Lcond e1 e2 e3 -> do 128 | e1' <- eliminateArray ary elems e1 129 | e2' <- eliminateArray ary elems e2 130 | e3' <- eliminateArray ary elems e3 131 | return $ Lcond e1' e2' e3' 132 | Lseq e1 e2 -> do 133 | e1' <- eliminateArray ary elems e1 134 | e2' <- eliminateArray ary elems e2 135 | return $ Lseq e1' e2' 136 | Lwhile e1 e2 -> do 137 | e1' <- eliminateArray ary elems e1 138 | e2' <- eliminateArray ary elems e2 139 | return $ Lwhile e1' e2' 140 | Lfor v e1 e2 e3 -> do 141 | e1' <- eliminateArray ary elems e1 142 | e2' <- eliminateArray ary elems e2 143 | e3' <- eliminateArray ary elems e3 144 | return $ Lfor v e1' e2' e3' 145 | Lassign v e -> do 146 | e' <- eliminateArray ary elems e 147 | return $ Lassign v e' 148 | 149 | arrayOpt = simplif 150 | -------------------------------------------------------------------------------- /src/AsmGen.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module AsmGen ( 7 | asmgen 8 | ) where 9 | 10 | import Choco 11 | import Coloring 12 | import Comballoc 13 | import Interf 14 | import Selection 15 | import Linearize 16 | import Liveness 17 | import LocalCSE 18 | import Mach 19 | import Schedular 20 | import Outputable 21 | import Proc 22 | import Reload 23 | import Reg 24 | import Schedular 25 | import Spill 26 | import Split 27 | 28 | import Control.Monad.State 29 | import qualified Data.Map as M 30 | 31 | liveness fun = Liveness.fundecl fun 32 | 33 | asmgen flags itab ftab fun = do 34 | resetRegs 35 | fun1 <- Selection.fundecl fun itab ftab 36 | when (dump_selection flags) $ 37 | report "After instruction selection" (ppr fun1) 38 | 39 | fun2 <- LocalCSE.fundecl fun1 40 | when (dump_lcse flags) $ 41 | report "After local common subexpression elimination" (ppr fun2) 42 | 43 | fun3 <- Comballoc.fundecl fun2 44 | when (dump_combine flags) $ 45 | report "After allocation combining" (ppr fun3) 46 | 47 | fun4 <- liveness fun3 48 | when (dump_live flags) $ 49 | report "Liveness analysis" (ppr fun4) 50 | 51 | fun5 <- Spill.fundecl fun4 52 | when (dump_spill flags) $ 53 | report "After spilling" (ppr fun5) 54 | 55 | fun6 <- Split.fundecl =<< liveness fun5 56 | when (dump_split flags) $ 57 | report "After live range splitting" (ppr fun6) 58 | 59 | (fun7, nslots) <- regalloc flags 1 =<< liveness fun6 60 | 61 | fun8 <- Linearize.fundecl fun7 62 | when (dump_linear flags) $ 63 | report "Linearized code" (ppr fun8) 64 | 65 | fun9 <- Schedular.fundecl fun8 66 | when (dump_scheduling flags) $ 67 | report "After instruction scheduling" (ppr fun9) 68 | 69 | return (fun9, nslots) 70 | 71 | regalloc flags round fd 72 | | round > 50 73 | = simpleError $ text "cannot complete register allocation:"<+> ppr fd 74 | | otherwise 75 | = do 76 | 77 | when (dump_live flags) $ 78 | report "Liveness analysis (during register allocation)" (ppr fd) 79 | 80 | Interf.buildGraph fd 81 | (fd', nslots) <- Coloring.allocateRegisters fd 82 | 83 | when (dump_regalloc flags) $ 84 | report "After register allocation" (ppr fd') 85 | 86 | (fd'', redo_regalloc) <- Reload.fundecl fd' 87 | when (dump_reload flags) $ 88 | report "After insertion of reloading code" (ppr fd'') 89 | 90 | if redo_regalloc 91 | then do 92 | reinitRegs 93 | fd''' <- liveness fd'' 94 | regalloc flags (round + 1) fd''' 95 | else return (fd'', nslots) 96 | 97 | -------------------------------------------------------------------------------- /src/CLamSyn.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module CLamSyn ( 7 | CLambda(..), occursVar 8 | ) where 9 | 10 | import Const 11 | import LamSyn hiding (occursVar) 12 | import Outputable 13 | import Types 14 | import Var 15 | 16 | import Control.Monad.State 17 | import qualified Data.Map as M 18 | import qualified Data.Set as S 19 | 20 | data CLambda 21 | = Uvar Var 22 | | Ulit Const 23 | | Uapply Var [CLambda] Bool -- true if it returns non unit value 24 | | Ulet (Var, CLambda) CLambda 25 | | Uprim Prim [CLambda] 26 | | Ucond CLambda CLambda CLambda 27 | | Useq CLambda CLambda 28 | | Uwhile CLambda CLambda 29 | | Ufor Var CLambda CLambda CLambda 30 | | Uassign Var CLambda 31 | | Uoffset CLambda Int 32 | | Uclosure (Var, [Var], CLambda) [CLambda] 33 | deriving (Eq, Show) 34 | 35 | instance Outputable CLambda where 36 | ppr (Uvar v) = ppr v 37 | ppr (Ulit c) = ppr c 38 | ppr (Uapply f args _) 39 | = parens $ text "apply" <+> ppr f <+> hsep (map ppr args) 40 | ppr (Ulet (v, e) body) 41 | = parens $ hang (text "let") 2 42 | (parens $ hang (ppr v) 2 (ppr e) $$ pprLet body) 43 | ppr (Uprim p args) 44 | = parens $ ppr p <+> hsep (map ppr args) 45 | 46 | ppr (Ucond e1 e2 e3) 47 | = parens $ text "if" <+> ppr e1 $$ ppr e2 $$ ppr e3 48 | 49 | ppr (Useq e1 e2) 50 | = parens $ hang (text "seq") 2 (sep [ppr e1, pprSeq e2]) 51 | where 52 | pprSeq (Useq e1 e2) = pprSeq e1 $$ pprSeq e2 53 | pprSeq e = ppr e 54 | 55 | ppr (Uwhile e1 e2) 56 | = parens $ text "while" <+> ppr e1 $$ ppr e2 57 | 58 | ppr (Ufor v e1 e2 e3) 59 | = parens $ text "for" <+> ppr v <+> text "in" <+> 60 | ppr e1 <+> text ".." <+> ppr e2 $$ ppr e3 61 | ppr (Uassign v e) 62 | = parens $ text "assign" <+> ppr v <+> ppr e 63 | 64 | ppr (Uoffset e n) 65 | = parens $ text "offset" <+> ppr e <+> ppr n 66 | 67 | ppr (Uclosure (f, params, body) _) 68 | = (parens $ hang (text "fun" <+> ppr f <+> (parens.hsep) (map ppr params)) 69 | 2 (ppr body)) 70 | 71 | pprLet (Ulet (v', e') body') 72 | = hang (ppr v') 2 (ppr e') $$ pprLet body' 73 | pprLet e = ppr e 74 | 75 | occursVar :: Var -> CLambda -> Bool 76 | occursVar var lam = case lam of 77 | Uvar v -> v == var && not (isGlobal v) 78 | Ulit _ -> False 79 | Uapply f args _ -> any (occursVar var) args 80 | Ulet (v, e) cont -> occursVar var e || occursVar var cont 81 | Uprim p args -> any (occursVar var) args 82 | Ucond l1 l2 l3 -> any (occursVar var) [l1, l2, l3] 83 | Useq l1 l2 -> any (occursVar var) [l1, l2] 84 | Uwhile l1 l2 -> any (occursVar var) [l1, l2] 85 | Ufor v l1 l2 l3 -> any (occursVar var) [l1, l2, l3] 86 | Uassign v e -> (v == var && not (isGlobal v)) || occursVar var e 87 | Uoffset e _ -> occursVar var e 88 | Uclosure _ clos -> any (occursVar var) clos 89 | 90 | -------------------------------------------------------------------------------- /src/Choco.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fglasgow-exts #-} 2 | ------------------------------------------------- 3 | -- Choco -- 4 | -- Chikadzume Oriented Compiler -- 5 | -- Copyright 2007-2008 by Basement fairy -- 6 | ------------------------------------------------- 7 | module Choco ( 8 | ChocoM, 9 | CFlags(..), 10 | CEnv(..), 11 | defaultCFlags, 12 | 13 | -- Choco APIs 14 | execChoco, 15 | compileError, 16 | simpleError, 17 | getFlag, 18 | report, 19 | putLog, 20 | trace, 21 | runIO, 22 | newUniq, 23 | newSymbol, 24 | 25 | ) where 26 | 27 | import Outputable 28 | import SrcLoc 29 | import Reg 30 | 31 | import Control.Monad.Error 32 | import Control.Monad.Reader.Class 33 | import Control.Monad.RWS 34 | import qualified Data.Map as M 35 | import Data.Sequence 36 | import Data.Traversable 37 | import System.Exit 38 | import Text.PrettyPrint.HughesPJ 39 | 40 | -- Monad for choco 41 | newtype ChocoM a = ChocoM { 42 | unChoco :: ErrorT CError (RWST CFlags CLogs CEnv IO) a 43 | } 44 | 45 | data CEnv = CEnv { 46 | uniq_source :: !Int, 47 | num_stack_slots :: !Int, -- fixme!! 48 | contains_calls :: Bool, 49 | reg_list :: [Reg], 50 | reg_info_table :: M.Map Reg RegInfo, 51 | phys_regs :: [Reg], 52 | reg_stamp :: Int, 53 | fun_reg_info :: M.Map String [Reg] 54 | } 55 | deriving (Show) 56 | 57 | initCEnv = CEnv { 58 | uniq_source = normalVarIdStart, 59 | num_stack_slots = 0, 60 | contains_calls = False, 61 | reg_list = [], 62 | reg_info_table = M.empty, 63 | phys_regs = [], 64 | reg_stamp = 0, 65 | fun_reg_info = M.empty 66 | } 67 | 68 | normalVarIdStart = 1000 69 | 70 | {- Flags -} 71 | data CFlags = CFlags { 72 | in_name :: String, -- name of the source file 73 | out_name :: String, -- name of the output file (without suffix) 74 | dump_parser :: Bool, -- dump output of the parser 75 | dump_typecheck :: Bool, -- dump output of the typechecker 76 | dump_unpoly :: Bool, -- dump output of the type specification 77 | dump_lambda :: Bool, -- dump output of the lambda transformer 78 | dump_simpl :: Bool, -- dump simplified lambda 79 | dump_close :: Bool, -- dump closed lambda 80 | dump_cmm :: Bool, -- dump cmm code 81 | dump_selection :: Bool, 82 | dump_lcse :: Bool, 83 | dump_combine :: Bool, 84 | dump_live :: Bool, 85 | dump_spill :: Bool, 86 | dump_split :: Bool, 87 | dump_linear :: Bool, 88 | dump_scheduling :: Bool, 89 | dump_interf :: Bool, 90 | dump_regalloc :: Bool, 91 | dump_reload :: Bool, 92 | opt_command :: String, 93 | assembler :: String, 94 | inline_threshold :: Int, 95 | address_base :: Int, 96 | use_nopflag :: Bool 97 | } 98 | 99 | defaultCFlags = CFlags { 100 | in_name = "", 101 | out_name = "", 102 | dump_parser = False, 103 | dump_typecheck = False, 104 | dump_unpoly = False, 105 | dump_lambda = False, 106 | dump_simpl = False, 107 | dump_close = False, 108 | dump_cmm = False, 109 | dump_selection = False, 110 | dump_combine = False, 111 | dump_lcse = False, 112 | dump_live = False, 113 | dump_spill = False, 114 | dump_split = False, 115 | dump_linear = False, 116 | dump_scheduling = False, 117 | dump_interf = False, 118 | dump_regalloc = False, 119 | dump_reload = False, 120 | opt_command = "lialialialialialaialialialialailaialialialia", 121 | assembler = "", 122 | inline_threshold = 100, 123 | address_base = 4096, 124 | use_nopflag = False 125 | } 126 | 127 | {- Error -} 128 | data CError 129 | = CompileError Doc SrcLoc 130 | | InternalError Doc 131 | deriving (Show) 132 | 133 | instance Error CError where 134 | strMsg msg = InternalError (text msg) 135 | 136 | {- Logging -} 137 | data CLog 138 | = LargeLog { 139 | title :: String, 140 | body :: Doc 141 | } 142 | | SmallLog Doc 143 | | DebugLog String 144 | deriving (Show) 145 | 146 | type CLogs = Seq CLog 147 | 148 | instance Outputable CLog where 149 | ppr (LargeLog title body) 150 | = text "=====" <+> text title <+> text "=====" $$ body 151 | 152 | ppr (SmallLog msg) = msg 153 | 154 | ppr (DebugLog msg) = text "Debug:" <+> text msg 155 | 156 | {- Choco APIs -} 157 | execChoco (ChocoM m) flags = do 158 | (result,_,logs) <- runRWST (runErrorT m) flags initCEnv 159 | 160 | {- 161 | for logs $ \log -> 162 | putStrLn $ render (ppr log) 163 | -} 164 | 165 | case result of 166 | Left err -> print err 167 | Right _ -> return () 168 | 169 | compileError :: Doc -> SrcLoc -> ChocoM a 170 | compileError msg loc = throwError (CompileError msg loc) 171 | 172 | simpleError :: Doc -> ChocoM a 173 | simpleError msg = throwError (CompileError msg noSrcLoc) 174 | 175 | runIO :: IO a -> ChocoM a 176 | runIO = liftIO 177 | 178 | getFlag :: (CFlags -> a) -> ChocoM a 179 | getFlag = asks 180 | 181 | newUniq :: ChocoM Int 182 | newUniq = do env@CEnv{ uniq_source = n } <- get 183 | put env{ uniq_source = n+1 } 184 | return n 185 | 186 | newSymbol :: String -> ChocoM String 187 | newSymbol str = newUniq >>= return . (str ++) . show 188 | 189 | report :: String -> Doc -> ChocoM () 190 | report title doc = runIO . putStrLn . render $ ppr (LargeLog title doc) 191 | 192 | putLog :: Doc -> ChocoM () 193 | putLog msg = runIO . putStrLn $ render msg 194 | 195 | trace :: Show a => a -> ChocoM () 196 | trace a = tell $ singleton (DebugLog (show a)) 197 | 198 | {- Instanciation -} 199 | instance Monad ChocoM where 200 | return a = ChocoM (return a) 201 | (ChocoM m) >>= f = ChocoM $ 202 | do a <- m 203 | unChoco (f a) 204 | 205 | instance MonadError CError ChocoM where 206 | throwError e = ChocoM (throwError e) 207 | catchError (ChocoM m) f = ChocoM (catchError m (unChoco.f)) 208 | 209 | instance MonadReader CFlags ChocoM where 210 | ask = ChocoM ask 211 | local f (ChocoM m) = ChocoM (local f m) 212 | 213 | instance MonadWriter CLogs ChocoM where 214 | tell w = ChocoM (tell w) 215 | listen (ChocoM m) = ChocoM (listen m) 216 | pass (ChocoM f) = ChocoM (pass f) 217 | 218 | instance MonadState CEnv ChocoM where 219 | get = ChocoM get 220 | put a = ChocoM (put a) 221 | 222 | instance MonadIO ChocoM where 223 | liftIO m = ChocoM (liftIO m) 224 | -------------------------------------------------------------------------------- /src/Closure.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Closure ( 7 | closeLambda 8 | ) where 9 | 10 | import Choco 11 | import Const 12 | import LamSyn hiding (occursVar) 13 | import CLamSyn 14 | import Outputable 15 | import Panic 16 | import Types 17 | import Var 18 | 19 | import Control.Monad.State 20 | import Data.Bits 21 | import qualified Data.Map as M 22 | import qualified Data.Set as S 23 | 24 | {- Closure conversion -} 25 | 26 | type P a = StateT Env ChocoM a 27 | data Env = Env { 28 | fun_nest_depth :: Int, 29 | fun_desc_table :: M.Map Var FunDesc 30 | } 31 | deriving (Show) 32 | 33 | initEnv = Env { 34 | fun_nest_depth = 0, 35 | fun_desc_table = M.empty 36 | } 37 | 38 | type FMap = M.Map Var (Maybe Var) 39 | type CMap = M.Map Var CLambda 40 | 41 | putFunDesc :: Var -> FunDesc -> P () 42 | putFunDesc id desc 43 | = modify $ \e@Env{ fun_desc_table = tbl } -> 44 | e{ fun_desc_table = M.insert id desc tbl } 45 | 46 | getFunDesc :: Var -> P FunDesc 47 | getFunDesc id 48 | = do tbl <- gets fun_desc_table 49 | case M.lookup id tbl of 50 | Just desc -> return desc 51 | Nothing -> panic "closure conversion error" 52 | 53 | modifyFunDesc :: Var -> (FunDesc -> FunDesc) -> P () 54 | modifyFunDesc v f = getFunDesc v >>= putFunDesc v . f 55 | 56 | type VarTable = M.Map Var Lambda 57 | 58 | data FunDesc = FunDesc { 59 | fun_label :: Var, 60 | fun_closed :: Bool 61 | } 62 | deriving (Show) 63 | 64 | close :: FMap -> CMap -> Lambda -> P (CLambda, Maybe Var) 65 | close fenv cenv (Lvar v) = return $ closeVar fenv cenv v 66 | close fenv cenv (Llit c) = return (Ulit c, Nothing) 67 | close fenv cenv lam@(Lfun params body) 68 | = do f <- lift$mkTmpVar "fun" (toScheme UnknownT) 69 | (clos, id) <- closeFunction fenv cenv f lam 70 | return (clos, Just id) 71 | 72 | close fenv cenv (Lapp f args p) 73 | = do (f', approx) <- close fenv cenv f 74 | case approx of 75 | Just label -> do 76 | args' <- mapM (close fenv cenv) args 77 | fdesc <- getFunDesc label 78 | app <- directApply fdesc f' label (fst.unzip $ args') p 79 | return (app, Nothing) 80 | Nothing -> lift$simpleError 81 | (text "Choco doesn't support direct function application") 82 | 83 | close fenv cenv (Llet _ (v, f@(Lfun _ _)) body) 84 | = do (clos, id) <- closeFunction fenv cenv v f 85 | (body', _) <- close (M.insert v (Just id) fenv) cenv body 86 | return (Ulet (v, clos) body', Just id) 87 | 88 | close fenv cenv (Llet str (v, e) body) 89 | = do 90 | (e', app) <- close fenv cenv e 91 | (body', _) <- close (M.insert v app fenv) cenv body 92 | return (Ulet (v, e') body', Nothing) 93 | 94 | close fenv cenv (Lletrec (v, f@(Lfun _ _)) body) 95 | = do (clos, id) <- closeFunction fenv cenv v f 96 | clos_ident <- lift$mkTmpVar "clos" (toScheme UnknownT) 97 | (body', _) <- close (M.insert v (Just id) fenv) cenv body 98 | body'' <- substitute (M.singleton id (Uoffset (Uvar clos_ident) 0)) body' 99 | return (Ulet (clos_ident, clos) body'', Just id) 100 | 101 | close fenv cenv (Lprim p args) 102 | = do args' <- mapM (close fenv cenv) args 103 | return (Uprim p (fst.unzip $ args'), Nothing) 104 | 105 | close fenv cenv (Lcond e1 e2 e3) 106 | = do (e1', _) <- close fenv cenv e1 107 | (e2', _) <- close fenv cenv e2 108 | (e3', _) <- close fenv cenv e3 109 | return (Ucond e1' e2' e3', Nothing) 110 | 111 | close fenv cenv (Lseq e1 e2) 112 | = do (e1', _) <- close fenv cenv e1 113 | (e2', e2_app) <- close fenv cenv e2 114 | return (Useq e1' e2', e2_app) 115 | 116 | close fenv cenv (Lwhile e1 e2) 117 | = do (e1', _) <- close fenv cenv e1 118 | (e2', _) <- close fenv cenv e2 119 | return (Uwhile e1' e2', Nothing) 120 | 121 | close fenv cenv (Lfor v e1 e2 e3) 122 | = do (e1', _) <- close fenv cenv e1 123 | (e2', _) <- close fenv cenv e2 124 | (e3', _) <- close fenv cenv e3 125 | return (Ufor v e1' e2' e3', Nothing) 126 | close fenv cenv (Lassign v e) 127 | = do (e', _) <- close fenv cenv e 128 | return (Uassign v e', Nothing) 129 | 130 | excessiveFunctionNestDepth = 5 131 | 132 | closeVar :: FMap -> CMap -> Var -> (CLambda, Maybe Var) 133 | closeVar fenv cenv v = 134 | (M.findWithDefault (Uvar v) v cenv, 135 | M.findWithDefault Nothing v fenv) 136 | 137 | closeFunction :: FMap -> CMap -> Var -> Lambda -> P (CLambda, Var) 138 | closeFunction fenv cenv id fun@(Lfun params body) 139 | = do nest <- return . (+ 1) =<< gets fun_nest_depth 140 | modify $ \e -> e{ fun_nest_depth = nest } 141 | let initially_closed = nest < excessiveFunctionNestDepth 142 | 143 | {- Determine the free variables of the functions -} 144 | let fv = filter (not.isGlobal) . S.toList $ 145 | freeVars (Lletrec (id, fun) (Llit UnitC)) 146 | 147 | {- Build function descriptor -} 148 | let fdesc = FunDesc { 149 | fun_label = id, fun_closed = initially_closed 150 | } 151 | putFunDesc id fdesc 152 | 153 | (clos, info) <- do 154 | if initially_closed 155 | then do 156 | (cl, useless_env) <- close_fundef id params body fv 157 | if useless_env 158 | then return cl 159 | else do 160 | modifyFunDesc id $ \f -> f{ fun_closed = False } 161 | ret <- close_fundef id params body fv 162 | return $ fst ret 163 | else do 164 | ret <- close_fundef id params body fv 165 | return $ fst ret 166 | 167 | let fv' = fst.unzip $ map (closeVar fenv cenv) fv 168 | 169 | modify $ \e -> e{ fun_nest_depth = nest - 1 } 170 | return $ (Uclosure clos fv', info) 171 | where 172 | close_fundef id params body fv 173 | = do 174 | env_param <- lift$mkTmpVar "env" (toScheme UnknownT) 175 | let cenv_fv = buildClosureEnv env_param 0 fv 176 | let cenv_body = M.insert id (Uoffset (Uvar env_param) 0) cenv_fv 177 | 178 | let fenv_rec = M.insert id (Just id) fenv 179 | (ubody,_) <- close fenv_rec cenv_body body 180 | let useless_env = not (occursVar env_param ubody) 181 | let params' = if useless_env then params else params ++ [env_param] 182 | return (((id, params', ubody), id), useless_env) 183 | 184 | buildClosureEnv env_param pos [] = M.empty 185 | buildClosureEnv env_param pos (id:rem) 186 | = M.insert id (Uprim (Pfield pos) [Uvar env_param]) 187 | (buildClosureEnv env_param (pos+1) rem) 188 | 189 | directApply fdesc fun cfun cargs p 190 | = do 191 | let app_args = if fun_closed fdesc then cargs else cargs ++ [Uvar cfun] 192 | return $ Uapply (fun_label fdesc) app_args p 193 | 194 | 195 | substitute subst lam 196 | = case lam of 197 | Uvar v -> return $ M.findWithDefault lam v subst 198 | Ulit _ -> return lam 199 | Uapply v args p 200 | -> do args' <- mapM (substitute subst) args 201 | return $ Uapply v args' p 202 | Ulet (id, e) body 203 | -> do id' <- lift$copyVar id 204 | e' <- substitute subst e 205 | body' <- substitute (M.insert id (Uvar id') subst) body 206 | return $ Ulet (id', e') body' 207 | Uprim p args 208 | -> do args' <- mapM (substitute subst) args 209 | return $ Uprim p args' 210 | Ucond e1 e2 e3 211 | -> do e1' <- substitute subst e1 212 | case e1' of 213 | Ulit (BoolC True) -> substitute subst e2 214 | Ulit (BoolC False) -> substitute subst e3 215 | _ -> do e2' <- substitute subst e2 216 | e3' <- substitute subst e3 217 | return $ Ucond e1' e2' e3' 218 | Useq e1 e2 219 | -> do e1' <- substitute subst e1 220 | e2' <- substitute subst e2 221 | return $ Useq e1' e2' 222 | 223 | Uwhile e1 e2 224 | -> do e1' <- substitute subst e1 225 | e2' <- substitute subst e2 226 | return $ Uwhile e1' e2' 227 | 228 | Ufor v e1 e2 e3 229 | -> do v' <- lift$copyVar v 230 | e1' <- substitute subst e1 231 | e2' <- substitute subst e2 232 | e3' <- substitute (M.insert v (Uvar v') subst) e3 233 | return $ Ufor v' e1' e2' e3' 234 | 235 | Uassign v e 236 | -> do e' <- substitute subst e 237 | return $ Uassign v e' 238 | 239 | Uclosure def clos 240 | -> do clos' <- mapM (substitute subst) clos 241 | return $ Uclosure def clos' 242 | 243 | Uoffset e n 244 | -> do e' <- substitute subst e 245 | return $ Uoffset e' n 246 | 247 | 248 | 249 | {- Interface -} 250 | closeLambda :: Lambda -> ChocoM CLambda 251 | closeLambda lam = return . fst =<< evalStateT (close M.empty M.empty lam) initEnv 252 | -------------------------------------------------------------------------------- /src/CmmSyn.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module CmmSyn ( 7 | MachType(..), 8 | voidType, intType, floatType, 9 | size, sizeType, 10 | Comp(..), negateComp, swapComp, 11 | MemoryChunk(..), Operation(..), Expr(..), FunDec(..), DataItem(..), 12 | Cmm(..), 13 | isSimpleCmm, 14 | 15 | -- pretty printing 16 | pprMachType 17 | ) where 18 | 19 | import Arch 20 | import Outputable 21 | 22 | type Ident = String -- temporal 23 | 24 | data MachType = Int | Float 25 | deriving (Eq, Show) 26 | 27 | voidType = [] 28 | intType = [Int] 29 | floatType = [Float] 30 | 31 | size Int = Arch.sizeInt 32 | size Float = Arch.sizeFloat 33 | 34 | sizeType = sum . map size 35 | 36 | 37 | data Comp 38 | = Ceq | Cne | Clt | Cle | Cgt | Cge 39 | deriving (Eq, Show) 40 | 41 | negateComp Ceq = Cne 42 | negateComp Cne = Ceq 43 | negateComp Clt = Cge 44 | negateComp Cle = Cgt 45 | negateComp Cgt = Cle 46 | negateComp Cge = Clt 47 | 48 | swapComp Ceq = Ceq 49 | swapComp Cne = Cne 50 | swapComp Clt = Cgt 51 | swapComp Cgt = Clt 52 | swapComp Cle = Cge 53 | swapComp Cge = Cle 54 | 55 | data MemoryChunk 56 | = Mem_Integer 57 | | Mem_Float 58 | | Mem_Addr 59 | deriving (Eq) 60 | 61 | data Operation 62 | = Capply Bool 63 | | Cextcall String Bool 64 | | Calloc 65 | | Cload 66 | | Cstore 67 | | Chsw Int | Chsr Int 68 | | Cregw Int | Cregr Int 69 | | Cfill Int 70 | | Cnegi | Caddi | Csubi | Cmuli | Cdivi | Clsl | Casr 71 | | Ccompi Comp 72 | | Cabsf | Cnegf | Caddf | Csubf | Cmulf | Cdivf | Csqrt | Cinv 73 | | Ccompf Comp 74 | | Cftoi | Citof 75 | | Cput 76 | deriving (Show, Eq) 77 | 78 | data Expr 79 | = Cconst_int Int 80 | | Cconst_float Float 81 | | Cconst_symbol String 82 | | Cvar Ident 83 | | Clet Ident Expr Expr 84 | | Cassign Ident Expr 85 | | Ctuple [Expr] 86 | | Cop Operation [Expr] 87 | | Cseq Expr Expr 88 | | Ccond Expr Expr Expr 89 | deriving (Show) 90 | 91 | isSimpleCmm (Cconst_int n) = True 92 | isSimpleCmm (Cconst_float f) = True 93 | isSimpleCmm (Cconst_symbol s) = True 94 | isSimpleCmm (Cop (Cregr _) _) = True 95 | isSimpleCmm (Cop (Cregw _) _) = True 96 | isSimpleCmm (Cvar _) = True 97 | isSimpleCmm _ = False 98 | 99 | data FunDec = FunDec { 100 | funName :: Ident, 101 | funArgs :: [(Ident, MachType)], 102 | funBody :: Expr 103 | } 104 | 105 | data DataItem 106 | = Cglobal_symbol String 107 | | Cint Int 108 | | Cfloat Float 109 | | Cskip Int 110 | | Cstatic_array Int Int 111 | | Cstatic_tuple Int 112 | 113 | 114 | data Cmm 115 | = Cdata [DataItem] 116 | | Cfunction FunDec 117 | 118 | 119 | instance Outputable MachType where 120 | ppr Int = text "int" 121 | ppr Float = text "float" 122 | 123 | pprMachType :: [MachType] -> Doc 124 | pprMachType [] = text "unit" 125 | pprMachType ts = hsep $ punctuate (char '*') (map ppr ts) 126 | 127 | instance Outputable Comp where 128 | ppr Ceq = text "==" 129 | ppr Cne = text "!=" 130 | ppr Clt = char '<' 131 | ppr Cgt = char '>' 132 | ppr Cle = text "<=" 133 | ppr Cge = text ">=" 134 | 135 | instance Outputable MemoryChunk where 136 | ppr Mem_Integer = text "int32" 137 | ppr Mem_Float = text "float32" 138 | ppr Mem_Addr = text "addr32" 139 | 140 | instance Outputable Operation where 141 | ppr (Capply _) = text "call" 142 | ppr (Cextcall s _) = text "extcall" <+> text s 143 | ppr Cload = text "load" 144 | ppr Calloc = text "alloc" 145 | ppr Cstore = text "store" 146 | ppr (Chsw n) = text "hsw" <+> int n 147 | ppr (Chsr n) = text "hsr" <+> int n 148 | ppr (Cregw n) = text "regw" <+> int n 149 | ppr (Cregr n) = text "regr" <+> int n 150 | ppr (Cfill n) = text "fill" <+> int n 151 | ppr Cnegi = text "negi" 152 | ppr Caddi = text "addi" 153 | ppr Csubi = text "subi" 154 | ppr Cmuli = text "muli" 155 | ppr Cdivi = text "divi" 156 | ppr Clsl = text "lsl" 157 | ppr Casr = text "asr" 158 | ppr (Ccompi c) = ppr c 159 | ppr Cabsf = text "fabs" 160 | ppr Cnegf = text "fneg" 161 | ppr Caddf = text "fadd" 162 | ppr Csubf = text "fsub" 163 | ppr Cmulf = text "fmul" 164 | ppr Cdivf = text "fdiv" 165 | ppr Csqrt = text "fsqrt" 166 | ppr Cinv = text "finv" 167 | ppr (Ccompf c) = ppr c <> char '.' 168 | ppr Cftoi = text "ftoi" 169 | ppr Citof = text "itof" 170 | ppr Cput = text "put" 171 | 172 | instance Outputable Expr where 173 | ppr (Cconst_int n) = int n 174 | ppr (Cconst_float f) = float f 175 | ppr (Cconst_symbol s) = text s 176 | ppr (Cvar s) = text s 177 | ppr (Clet id e cont) 178 | = parens (text "let" <+> text id <+> ppr e $$ ppr cont) 179 | ppr (Cassign s e) = parens $ text "assign" <+> text s <+> ppr e 180 | ppr (Ctuple []) = text "()" 181 | ppr (Ctuple es) = parens $ (text "tuple") <+> (hsep (map ppr es)) 182 | ppr (Cop op args) = parens $ ppr op <+> hsep (map ppr args) 183 | ppr (Cseq e1 e2) = parens (ppr e1 $$ pprSeq e2) 184 | ppr (Ccond e1 e2 e3) = 185 | parens $ hang (text "if" <+> ppr e1) 2 (ppr e2 $$ ppr e3) 186 | 187 | pprSeq (Cseq e1 e2) = ppr e1 $$ pprSeq e2 188 | pprSeq e = ppr e 189 | 190 | instance Outputable FunDec where 191 | ppr f = parens $ hang (text "function" <+> text (funName f) <+> 192 | parens pprArgs) 2 (parens.ppr.funBody $ f) 193 | where 194 | pprArgs = hsep $ 195 | map (\(id, ty) -> text id <> char ':' <> ppr ty) (funArgs f) 196 | 197 | instance Outputable DataItem where 198 | ppr (Cglobal_symbol s) = text "global" <+> doubleQuotes (text s) 199 | ppr (Cint n) = text "int32" <+> int n 200 | ppr (Cfloat f) = text "float32" <+> float f 201 | ppr (Cskip n) = text "skip" <+> int n 202 | ppr (Cstatic_array s n) = text "array" <+> int s <+> int n 203 | ppr (Cstatic_tuple n) = text "tuple" <+> int n 204 | 205 | instance Outputable Cmm where 206 | ppr (Cdata dl) = text "data" <+> hsep (map ppr dl) 207 | ppr (Cfunction f) = ppr f 208 | -------------------------------------------------------------------------------- /src/Comballoc.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Comballoc where 7 | 8 | import Mach 9 | import Reg 10 | 11 | data AllocationState 12 | = NoAlloc 13 | | PendingAlloc Reg Int 14 | 15 | allocatedSize NoAlloc = 0 16 | allocatedSize (PendingAlloc _ n) = n 17 | 18 | combine i allocstate = 19 | case idesc i of 20 | Iend -> (i, allocatedSize allocstate) 21 | Ireturn -> (i, allocatedSize allocstate) 22 | Iop (Ialloc size) -> 23 | case allocstate of 24 | NoAlloc -> 25 | let (newnext, newsize) = combine (next i) (PendingAlloc (result i !! 0) size) 26 | in (consInst (Iop (Ialloc newsize)) (result i) (args i) newnext, 0) 27 | PendingAlloc reg ofs -> 28 | let (newnext, newsize) = combine (next i) (PendingAlloc reg (ofs + size)) 29 | in (consInst (Iop (Iintop_imm Iadd ofs)) 30 | (result i) [reg] newnext, 31 | newsize) 32 | Iop Icall_ind -> 33 | let newnext = combine_restart (next i) in 34 | (consInst (idesc i) (result i) (args i) newnext, 35 | allocatedSize allocstate) 36 | 37 | Iop (Icall_imm _) -> 38 | let newnext = combine_restart (next i) in 39 | (consInst (idesc i) (result i) (args i) newnext, 40 | allocatedSize allocstate) 41 | 42 | Iop Itailcall_ind -> 43 | let newnext = combine_restart (next i) in 44 | (consInst (idesc i) (result i) (args i) newnext, 45 | allocatedSize allocstate) 46 | 47 | Iop (Itailcall_imm _) -> 48 | let newnext = combine_restart (next i) in 49 | (consInst (idesc i) (result i) (args i) newnext, 50 | allocatedSize allocstate) 51 | 52 | Iop op -> 53 | let (newnext, newsize) = combine (next i) allocstate 54 | in (consInst (idesc i) (result i) (args i) newnext, newsize) 55 | 56 | Icond tst ifso ifnot -> 57 | let newifso = combine_restart ifso 58 | newifnot = combine_restart ifnot 59 | newnext = combine_restart (next i) 60 | in (consInst (Icond tst newifso newifnot) 61 | (result i) (args i) newnext, 62 | allocatedSize allocstate) 63 | 64 | combine_restart i = fst $ combine i NoAlloc 65 | 66 | 67 | fundecl f = return f{ fun_body = combine_restart (fun_body f) } 68 | -------------------------------------------------------------------------------- /src/Common.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Common ( 7 | RecFlag(..) 8 | ) where 9 | 10 | data RecFlag = Rec | NonRec 11 | deriving (Show, Eq) 12 | -------------------------------------------------------------------------------- /src/Const.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Const ( 7 | Const(..), 8 | nullPtr 9 | ) where 10 | 11 | import Outputable 12 | 13 | {- constant values -} 14 | 15 | data Const 16 | = IntC Int 17 | | FloatC Float 18 | | UnitC 19 | | BoolC Bool 20 | | PointerC Int 21 | deriving (Eq) 22 | 23 | nullPtr = PointerC 0 24 | 25 | instance Outputable Const where 26 | ppr (IntC i) = int i 27 | ppr (FloatC f) = float f 28 | ppr UnitC = text "()" 29 | ppr (BoolC True) = text "true" 30 | ppr (BoolC False) = text "false" 31 | ppr (PointerC 0) = text "null" 32 | ppr (PointerC n) = text "p" <> int n 33 | 34 | instance Show Const where 35 | show = show.ppr 36 | -------------------------------------------------------------------------------- /src/Driver.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Driver ( 7 | getCFlags 8 | ) where 9 | 10 | import Choco 11 | 12 | import Control.Monad 13 | import Data.List 14 | import System.Console.GetOpt 15 | import System.IO.Unsafe 16 | import System.Environment 17 | import System.Exit 18 | 19 | data Opt 20 | = OutName String 21 | | DParser 22 | | DTypeCheck 23 | | DUnpoly 24 | | DLambda 25 | | DSimpl 26 | | DClose 27 | | DCmm 28 | | DSelection 29 | | DLcse 30 | | DCombine 31 | | DLive 32 | | DSpill 33 | | DSplit 34 | | DLinear 35 | | DScheduling 36 | | DInterf 37 | | DRegalloc 38 | | DReload 39 | | OptCmd String 40 | | InlineThreshold String 41 | | Asm String 42 | | Base String 43 | | NopFlag 44 | | Help 45 | 46 | progName :: String 47 | progName = unsafePerformIO (getProgName) 48 | 49 | usage :: String 50 | usage = usageInfo ("Usage : " ++ progName ++ " [options]") options 51 | 52 | options :: [OptDescr Opt] 53 | options = 54 | [ Option ['h'] ["help"] (NoArg Help) "show this help" 55 | , Option ['o'] ["ofile"] (ReqArg OutName "OUTPUT_FILE") 56 | $ "output file (default is FILENAME.as)" 57 | , Option [] ["dump-parser"] (NoArg DParser) 58 | "dump parser output" 59 | , Option [] ["dump-typecheck"] (NoArg DTypeCheck) 60 | "dump code after typecheck" 61 | , Option [] ["dump-unpoly"] (NoArg DUnpoly) 62 | "dump code after specification of polymorphic functions" 63 | , Option [] ["dump-lambda"] (NoArg DLambda) 64 | "dump code after lambda transformation" 65 | , Option [] ["dump-simpl"] (NoArg DSimpl) 66 | "dump simplified lambda" 67 | , Option [] ["dump-close"] (NoArg DClose) 68 | "dump closed lambda" 69 | , Option [] ["dump-cmm"] (NoArg DCmm) 70 | "dump code of c--" 71 | , Option [] ["dump-selection"] (NoArg DSelection) 72 | "dump code after instruction selection" 73 | , Option [] ["dump-lcse"] (NoArg DLcse) 74 | "dump code after local common subexpression elimination" 75 | , Option [] ["dump-combine"] (NoArg DCombine) 76 | "dump code after allocation combining" 77 | , Option [] ["dump-live"] (NoArg DLive) 78 | "dump result of liveness analysis" 79 | , Option [] ["dump-spill"] (NoArg DSpill) 80 | "dump code after spilling" 81 | , Option [] ["dump-split"] (NoArg DSplit) 82 | "dump code after live range splitting" 83 | , Option [] ["dump-linear"] (NoArg DLinear) 84 | "dump linearized code" 85 | , Option [] ["dump-scheduling"] (NoArg DScheduling) 86 | "dump code after instruction scheduling" 87 | , Option [] ["dump-interf"] (NoArg DInterf) 88 | "dump interferences" 89 | , Option [] ["dump-regalloc"] (NoArg DRegalloc) 90 | "dump code after regiater allocation" 91 | , Option [] ["dump-reload"] (NoArg DReload) 92 | "dump code after insertion of reloading code" 93 | , Option [] ["opt"] (ReqArg OptCmd "[lia]*") 94 | $ "optimize lambda by specified optimization sequence\n" ++ 95 | "\tl : eliminate unnecessary let bindings" ++ 96 | "\ti : perform inlining" ++ 97 | "\ta : optimize array operations" 98 | , Option [] ["inline"] (ReqArg InlineThreshold "THRESHOLD") 99 | "inline thresholod" 100 | , Option [] ["asm"] (ReqArg Asm "PATH_TO_ASSEMBLER") 101 | "generate binary by specified assembler" 102 | , Option [] ["base"] (ReqArg Base "BASE_ADDRESS") 103 | "base address" 104 | , Option [] ["withnop"] (NoArg NopFlag) 105 | "use nop-flag" 106 | ] 107 | 108 | getOpts :: [String] -> IO ([Opt], [String]) 109 | getOpts argv = 110 | case getOpt Permute options argv of 111 | (o, n, []) -> return (o, n) 112 | (_, _, errs) -> ioError (userError (concat errs ++ usage)) 113 | 114 | buildFlags :: ([Opt], [String]) -> IO CFlags 115 | buildFlags (opts, inputs) = 116 | if null inputs 117 | then foldM dispatch defaultCFlags opts 118 | else let i = head inputs 119 | out = if ".ml" `isSuffixOf` i 120 | then fst (splitAt (length i - 3) i) ++ ".as" 121 | else i ++ ".as" 122 | in foldM dispatch 123 | defaultCFlags{ in_name = i, 124 | out_name = out 125 | } opts 126 | where 127 | dispatch _ Help = putStrLn usage >> exitWith ExitSuccess 128 | dispatch info (OutName file) = return info{ out_name = file} 129 | dispatch info DParser = return info{ dump_parser = True } 130 | dispatch info DTypeCheck = return info{ dump_typecheck = True } 131 | dispatch info DUnpoly = return info{ dump_unpoly = True } 132 | dispatch info DLambda = return info{ dump_lambda = True } 133 | dispatch info DSimpl = return info{ dump_simpl = True } 134 | dispatch info DClose = return info{ dump_close = True } 135 | dispatch info DCmm = return info{ dump_cmm = True } 136 | dispatch info DSelection = return info{ dump_selection = True } 137 | dispatch info DLcse = return info{ dump_lcse = True } 138 | dispatch info DCombine = return info{ dump_combine = True } 139 | dispatch info DLive = return info{ dump_live = True } 140 | dispatch info DSpill = return info{ dump_spill = True } 141 | dispatch info DSplit = return info{ dump_split = True } 142 | dispatch info DLinear = return info{ dump_linear = True } 143 | dispatch info DScheduling = return info{ dump_scheduling = True } 144 | dispatch info DInterf = return info{ dump_interf = True } 145 | dispatch info DRegalloc = return info{ dump_regalloc = True } 146 | dispatch info DReload = return info{ dump_reload = True } 147 | dispatch info (OptCmd cmd) = return info{ opt_command = cmd } 148 | dispatch info NopFlag = return info{ use_nopflag = True } 149 | dispatch info (Asm cmd) = return info{ assembler = cmd } 150 | dispatch info (Base base) = return info{ address_base = read base } 151 | dispatch info (InlineThreshold s) 152 | = do let t = (read s) :: Int 153 | if t < 0 154 | then putStrLn usage >> exitWith ExitSuccess 155 | else return info{ inline_threshold = t } 156 | 157 | getCFlags :: IO CFlags 158 | getCFlags = getArgs >>= getOpts >>= buildFlags 159 | -------------------------------------------------------------------------------- /src/ElimLet.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module ElimLet ( 7 | simplifyLets 8 | ) where 9 | 10 | import Choco 11 | import Const 12 | import Id 13 | import LamSyn 14 | import Outputable 15 | import Panic 16 | import Var 17 | 18 | import Control.Monad.State 19 | import qualified Data.IntMap as I 20 | import qualified Data.Map as M 21 | import Data.Maybe 22 | 23 | type P a = StateT Env ChocoM a 24 | 25 | data Env = Env { 26 | -- table of occurrence count and read-only flag 27 | occ_table :: M.Map Var (Int, Bool), 28 | 29 | subst_map :: M.Map Var Lambda 30 | } 31 | 32 | initEnv = Env { 33 | occ_table = M.empty, 34 | subst_map = M.empty 35 | } 36 | 37 | incrVar v n = do 38 | e@Env{ occ_table = map } <- get 39 | let (c, r) = M.findWithDefault (0, True) v map 40 | put e{ occ_table = M.insert v (c+n, r) map } 41 | 42 | getVarCount v = do 43 | e@Env{ occ_table = map } <- get 44 | return $ M.findWithDefault (0, True) v map 45 | 46 | notReadonly v = do 47 | e@Env{ occ_table = map } <- get 48 | let (c, _) = M.findWithDefault (0, panic "notReadonly") v map 49 | put e{ occ_table = M.insert v (c, False) map } 50 | 51 | countVars :: Lambda -> P () 52 | countVars (Lvar v) = incrVar v 1 53 | countVars (Llit _) = return () 54 | countVars (Lapp f args _) = mapM_ countVars (f:args) 55 | countVars (Lfun _ body) = countVars body 56 | countVars (Llet _ (v, Lvar w) e) 57 | {- v will be replaced by w in e, so each occurence of v in e 58 | - increases w's refcount -} 59 | = do countVars e 60 | (vc, vr) <- getVarCount v 61 | e@Env{ occ_table = occ } <- get 62 | case M.lookup w occ of 63 | Just (c, r) -> 64 | put e{ occ_table = M.insert w (c + vc, r && vr) occ } 65 | Nothing -> put e{ occ_table = M.insert w (vc, vr) occ } 66 | countVars (Llet str (v, e) body) 67 | = do countVars body 68 | (vc, _) <- getVarCount v 69 | when (str == Strict || vc > 1) (countVars e) 70 | countVars (Lletrec (v, e) body) = mapM_ countVars [e,body] 71 | countVars (Lprim _ args) = mapM_ countVars args 72 | countVars (Lcond e1 e2 e3) = mapM_ countVars [e1,e2,e3] 73 | countVars (Lseq e1 e2) = mapM_ countVars [e1,e2] 74 | countVars (Lassign v e) = do { notReadonly v; countVars e } 75 | countVars (Lfor v beg end body) 76 | = do { notReadonly v; countVars beg; countVars end; countVars body } 77 | countVars (Lwhile e body) 78 | = do { countVars e; countVars body } 79 | 80 | 81 | addSubst :: Var -> Lambda -> P () 82 | addSubst v w 83 | = modify $ \e -> e{ subst_map = M.insert v w (subst_map e) } 84 | 85 | elimLet :: Lambda -> P Lambda 86 | elimLet l@(Lvar v) 87 | = do Env{ subst_map = map } <- get 88 | return $ M.findWithDefault l v map 89 | 90 | elimLet l@(Llit c) = return l 91 | elimLet (Lapp f args p) 92 | = do f' <- elimLet f 93 | args' <- mapM elimLet args 94 | return $ Lapp f' args' p 95 | elimLet (Lfun args body) 96 | = do body' <- elimLet body 97 | return $ Lfun args body' 98 | elimLet (Llet Strict (v, Lvar w) e) 99 | = do w' <- elimLet (Lvar w) 100 | addSubst v w' 101 | elimLet e 102 | elimLet (Llet str (v, e) cont) 103 | | hasSideEffect e 104 | = do e' <- elimLet e 105 | cont' <- elimLet cont 106 | return $ Llet str (v, e') cont' 107 | elimLet (Llet Strict (v, e) cont) 108 | = do (vc, _) <- getVarCount v 109 | case vc of 110 | 0 -> do lift$putLog$ text "\teliminate unused" <+> ppr v 111 | elimLet cont 112 | 1 -> do e' <- elimLet e 113 | addSubst v e' 114 | lift$putLog$ text "\tinline" <+> ppr v 115 | elimLet cont 116 | _ -> do e' <- elimLet e 117 | cont' <- elimLet cont 118 | return $ Llet Strict (v, e') cont' 119 | elimLet (Llet str (v, e) cont) 120 | = do e' <- elimLet e 121 | cont' <- elimLet cont 122 | r <- getVarCount v 123 | case r of 124 | -- (0, _) -> return cont' 125 | (_, True) -> return $ Llet Strict (v, e') cont' 126 | (_, False) -> return $ Llet Variable (v, e') cont' 127 | elimLet (Lletrec (v, e) cont) 128 | = do e' <- elimLet e 129 | cont' <- elimLet cont 130 | return $ Lletrec (v, e') cont' 131 | elimLet (Lprim p args) 132 | = do args' <- mapM elimLet args 133 | return $ Lprim p args' 134 | elimLet (Lcond e1 e2 e3) 135 | = do e1' <- elimLet e1 136 | e2' <- elimLet e2 137 | e3' <- elimLet e3 138 | return $ Lcond e1' e2' e3' 139 | elimLet (Lseq e1 e2) 140 | = do e1' <- elimLet e1 141 | e2' <- elimLet e2 142 | return $ Lseq e1' e2' 143 | elimLet (Lwhile e1 e2) 144 | = do e1' <- elimLet e1 145 | e2' <- elimLet e2 146 | return $ Lwhile e1' e2' 147 | elimLet (Lfor v e1 e2 e3) 148 | = do e1' <- elimLet e1 149 | e2' <- elimLet e2 150 | e3' <- elimLet e3 151 | return $ Lfor v e1' e2' e3' 152 | elimLet (Lassign v e) 153 | = do (vc, _) <- getVarCount v 154 | case vc of 155 | 0 -> return $ Llit UnitC 156 | _ -> do 157 | e' <- elimLet e 158 | return $ Lassign v e' 159 | 160 | {- Interface -} 161 | simplifyLets :: Lambda -> ChocoM Lambda 162 | simplifyLets lam = evalStateT (countVars lam >> elimLet lam) initEnv 163 | -------------------------------------------------------------------------------- /src/Error.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Error () where 7 | 8 | -------------------------------------------------------------------------------- /src/Flags.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Flags ( 7 | CFlags(..), 8 | defaultCFlags 9 | ) where 10 | 11 | data CFlags = CFlags { 12 | in_name :: String, -- name of the source file 13 | out_name :: String, -- name of the output file (without suffix) 14 | dump_parser :: Bool, -- dump output of the parser 15 | dump_typecheck :: Bool, -- dump output of the typechecker 16 | dump_lambda :: Bool, -- dump output of the lambda transformer 17 | dump_simpl :: Bool -- dump simplified lambda 18 | } 19 | 20 | defaultCFlags = CFlags { 21 | in_name = "", 22 | out_name = "a", 23 | dump_parser = False, 24 | dump_typecheck = False, 25 | dump_lambda = False, 26 | dump_simpl = False 27 | } 28 | -------------------------------------------------------------------------------- /src/Hoisting.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Hoisting where 7 | 8 | import CmmSyn 9 | 10 | 11 | hoist inst = case inst of 12 | -------------------------------------------------------------------------------- /src/Id.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Id ( 7 | Id, genIdSource, newId, pprId, 8 | IdMap, IdSet 9 | ) where 10 | 11 | import Outputable 12 | 13 | import Data.IORef 14 | import qualified Data.IntMap as I 15 | import qualified Data.Set as S 16 | import System.IO.Unsafe 17 | 18 | {- identifiers -} 19 | 20 | 21 | ----------------------------------------------------------- 22 | -- identification number 23 | ----------------------------------------------------------- 24 | 25 | type Id = Int 26 | type IdMap e = I.IntMap e 27 | type IdSet = S.Set Id 28 | 29 | genIdSource :: Int -> IORef Int 30 | genIdSource = unsafePerformIO . newIORef 31 | 32 | newId :: IORef Int -> Id 33 | newId source = unsafePerformIO $ 34 | do n <- readIORef source 35 | writeIORef source (n+1) 36 | return n 37 | 38 | pprId :: Id -> Doc 39 | pprId = int 40 | {-# NOINLINE genIdSource #-} 41 | {-# NOINLINE newId #-} 42 | -------------------------------------------------------------------------------- /src/Interf.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Interf where 7 | 8 | import Choco 9 | import Mach ( Inst(..), InstDesc(..), Operation(..), FunDec(..) ) 10 | import Outputable 11 | import Proc 12 | import Reg 13 | import RegM 14 | 15 | import Control.Monad.State 16 | import qualified Data.Set as S 17 | 18 | type P a = StateT (S.Set (Int, Int)) ChocoM a 19 | 20 | 21 | 22 | -- Record an interference between two registers 23 | addInterf :: Reg -> Reg -> P () 24 | addInterf ri rj = do 25 | let i = stamp ri; j = stamp rj 26 | when (i /= j) $ do 27 | let pair = if i < j then (i, j) else (j, i) 28 | mat <- get 29 | when (S.notMember pair mat) $ do 30 | modify $ S.insert pair 31 | lift $ modifyRegInfo ri $ \i -> i{ interf = rj : (interf i) } 32 | lift $ modifyRegInfo rj $ \i -> i{ interf = ri : (interf i) } 33 | 34 | -- Record interferences between register lists 35 | addInterfSet :: [Reg] -> S.Set Reg -> P () 36 | addInterfSet v s = mapM_ (uncurry addInterf) 37 | [(x, y)| x <- v, y <- S.toList s] 38 | 39 | -- Record interferences between elements of a list 40 | addInterfSelf :: [Reg] -> P () 41 | addInterfSelf (x:xs) = do mapM (addInterf x) xs 42 | addInterfSelf xs 43 | addInterfSelf [] = return () 44 | 45 | -- Record interferences between the destination of a move and a set 46 | -- of live registers. Since the destination is equal to the source, 47 | -- do not add an interference between them if the source is still live 48 | addInterfMove :: Reg -> Reg -> S.Set Reg -> P () 49 | addInterfMove src dst live 50 | = mapM_ (\r -> when (stamp r /= stamp src) (addInterf dst r)) 51 | (S.toList live) 52 | 53 | 54 | -- Compute interferences 55 | computeInterf :: Inst -> P () 56 | computeInterf i = do 57 | destroyed <- lift$destroyedAtOper (idesc i) 58 | when (not (null destroyed)) $ 59 | addInterfSet destroyed (live i) 60 | case (idesc i) of 61 | Iend -> return () 62 | Ireturn -> return () 63 | Iop op | op `elem` [Imove, Ispill, Ireload] 64 | -> do addInterfMove (args i !! 0) (result i !! 0) (live i) 65 | computeInterf (next i) 66 | Iop Itailcall_ind -> return () 67 | Iop (Itailcall_imm _) -> return () 68 | Iop op 69 | -> do addInterfSet (result i) (live i) 70 | addInterfSelf (result i) 71 | computeInterf (next i) 72 | 73 | Icond tst ifso ifnot 74 | -> do computeInterf ifso 75 | computeInterf ifnot 76 | computeInterf (next i) 77 | 78 | -- Add a preference from one reg to another. 79 | -- Do not add anything if the two registers conflict, 80 | -- or if the source register already has a location. 81 | addPref weight ri rj = 82 | when (weight > 0) $ do 83 | let i = stamp ri; j = stamp rj 84 | mat <- get 85 | when (i /= j && loc ri == Unknown && 86 | (let p = if i < j then (i, j) else (j, i) in S.notMember p mat)) $ do 87 | lift $ modifyRegInfo ri $ \i -> i{ prefer = (rj, weight) : prefer i } 88 | 89 | 90 | -- Add a mutual preference between two regs 91 | addMutualPref weight ri rj = addPref weight ri rj >> addPref weight rj ri 92 | 93 | 94 | -- Update the spill cost of the registers involved in an operation 95 | addSpillCost cost args = 96 | mapM_ (\r -> 97 | lift $ modifyRegInfo r $ \i -> i{ spillCost = (spillCost i) + cost }) 98 | args 99 | 100 | -- Compute preference and spill costs 101 | computePrefer w i = do 102 | addSpillCost w (args i) 103 | addSpillCost w (result i) 104 | case idesc i of 105 | Iend -> return () 106 | Ireturn -> return () 107 | Iop Imove -> do 108 | addMutualPref w (args i !! 0) (result i !! 0) 109 | computePrefer w (next i) 110 | Iop Ispill -> do 111 | addPref (w `div` 4) (args i !! 0) (result i !! 0) 112 | computePrefer w (next i) 113 | Iop Ireload -> do 114 | addPref (w `div` 4) (result i !! 0) (args i !! 0) 115 | computePrefer w (next i) 116 | Iop Itailcall_ind -> return () 117 | Iop (Itailcall_imm _) -> return () 118 | Iop op -> computePrefer w (next i) 119 | Icond tst ifso ifnot -> do 120 | computePrefer (w `div` 2) ifso 121 | computePrefer (w `div` 2) ifnot 122 | computePrefer w (next i) 123 | 124 | buildGraph fun = 125 | evalStateT (computeInterf (fun_body fun) >> computePrefer 8 (fun_body fun)) S.empty 126 | -------------------------------------------------------------------------------- /src/LamGen.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module LamGen ( 7 | translLambda 8 | ) where 9 | 10 | import Choco 11 | import Common 12 | import Const 13 | import LamSyn 14 | import Panic 15 | import Primitive 16 | import Outputable 17 | import SrcLoc 18 | import TcSyn 19 | import Types 20 | import Var 21 | 22 | import Control.Monad.State 23 | import qualified Data.Map as M 24 | import qualified Data.Set as S 25 | import Data.Maybe 26 | 27 | {- Lambda transformation Monad -} 28 | type LamM a = StateT () ChocoM a 29 | 30 | {- translate typed-expression to typed-lambda-language -} 31 | translStmts :: [LTcStmt] -> LamM Lambda 32 | translStmts [L _ (TcEvalS e)] = translExpr e 33 | translStmts [L _ (TcValueS _)] = return $ Llit UnitC 34 | translStmts (L _ (TcEvalS e) : rem) 35 | = do e' <- translExpr e 36 | rem' <- translStmts rem 37 | return $ Lseq e' rem' 38 | translStmts (L _ (TcValueS bind) : rem) 39 | = do rem' <- translStmts rem 40 | translLet bind rem' 41 | 42 | 43 | translExpr :: TcExpr -> LamM Lambda 44 | translExpr e 45 | = case expr_desc e of 46 | TcVarE v -> return $ Lvar v 47 | TcLitE c -> return $ Llit c 48 | TcAppE f args 49 | -> do translApply f args 50 | 51 | TcPrefixE op e 52 | -> do e' <- translExpr e 53 | return $ (Lprim (translPreOp op (expr_type e)) [e']) 54 | 55 | TcInfixE op e1 e2 56 | -> do e1' <- translExpr e1 57 | e2' <- translExpr e2 58 | return $ (Lprim (translBinOp op (expr_type e2)) [e1', e2']) 59 | 60 | TcLetE rec bind body 61 | -> do body' <- translExpr body 62 | translLet bind body' 63 | 64 | TcFunE args body 65 | -> translFunction args body 66 | 67 | TcTupleE elems 68 | -> do elems' <- mapM translExpr elems 69 | return $ (Lprim PcreateTuple elems') 70 | 71 | TcCondE e1 e2 e3 72 | -> do e1' <- translExpr e1 73 | e2' <- translExpr e2 74 | e3' <- translExpr e3 75 | return $ Lcond e1' e2' e3' 76 | 77 | TcSeqE e1 e2 78 | -> do e1' <- translExpr e1 79 | e2' <- translExpr e2 80 | return $ Lseq e1' e2' 81 | 82 | translApply :: TcExpr -> [TcExpr] -> LamM Lambda 83 | translApply f args 84 | = do let FunT _ ret = expr_type f 85 | let retp = if ret /= UnitT then True else False 86 | f' <- translExpr f 87 | args' <- mapM translExpr args 88 | case f' of 89 | (Lapp f2 args2 p) -> return $ Lapp f2 (args2 ++ args') retp 90 | (Lvar v) | isGlobal v -> 91 | case M.lookup (var_name v) (snd primTable) of 92 | Just fn -> return (fn args') 93 | Nothing -> return $ Lapp f' args' retp 94 | _ -> return $ Lapp f' args' retp 95 | 96 | isSimpleLambda :: Lambda -> Bool 97 | isSimpleLambda lam 98 | = case lam of 99 | Lvar _ -> True 100 | Llit (FloatC _) -> False 101 | Llit _ -> True 102 | _ -> False 103 | 104 | translLet :: (TcPat, TcExpr) -> Lambda -> LamM Lambda 105 | translLet (pat, expr) cont 106 | = do expr' <- translExpr expr 107 | case pat_desc pat of 108 | TcAnyP -> return $ Lseq expr' cont 109 | TcVarP v -> if not $ checkRecursive [v] expr' 110 | then return $ Lletrec (v, expr') cont 111 | else return $ Llet Strict (v, expr') cont 112 | TcTupleP pats 113 | -> if isSimpleLambda expr' 114 | then return =<< walk pats 0 expr' cont 115 | else do v <- lift $ mkTmpVar "match" (toScheme $ expr_type expr) 116 | lam <- walk pats 0 (Lvar v) cont 117 | return $ Llet Strict (v, expr') lam 118 | where 119 | walk [] _ expr cont = return cont 120 | walk (TcPat TcAnyP _ _ : rem) i expr cont 121 | = walk rem (i+1) expr cont 122 | walk (TcPat (TcVarP v) _ _ : rem) i expr cont 123 | = walk rem (i+1) expr 124 | (Llet Strict (v, (Lprim (PtupleRef i) [expr])) cont) 125 | walk (TcPat (TcTupleP pats) _ _ : rem) i expr cont 126 | = do cont' <- walk pats 0 (Lprim (PtupleRef i) [expr]) cont 127 | walk rem (i+1) expr cont' 128 | 129 | translFunction :: [TcPat] -> TcExpr -> LamM Lambda 130 | translFunction pats body = do 131 | body' <- translExpr body 132 | walk pats [] body' 133 | where 134 | walk [] args body = return $ Lfun (reverse args) body 135 | walk (TcPat TcAnyP _ ty : rem) args body 136 | = do v <- lift $ mkTmpVar "a" (toScheme ty) 137 | walk rem (v : args) body 138 | walk (TcPat (TcVarP v) _ ty : rem) args body 139 | = walk rem (v : args) body 140 | walk (p@(TcPat (TcTupleP pats) _ ty) : rem) args body 141 | = do v <- lift $ mkTmpVar "t" (toScheme ty) 142 | body' <- translLet (p, TcExpr (TcVarE v) noSrcLoc ty) body 143 | walk rem (v : args) body' 144 | 145 | translPreOp :: PreOp -> Type -> Prim 146 | translPreOp op _ 147 | = case op of 148 | Neg -> Pnegi 149 | FNeg -> Pnegf 150 | 151 | translBinOp :: BinOp -> Type -> Prim 152 | translBinOp op t 153 | = case op of 154 | Add -> Paddi 155 | Sub -> Psubi 156 | Mul -> Pmuli 157 | Div -> Pdivi 158 | FAdd -> Paddf 159 | FSub -> Psubf 160 | FMul -> Pmulf 161 | FDiv -> Pdivf 162 | cmp -> (cmptype t) (transl op) 163 | where 164 | cmptype IntT = Pcompi 165 | cmptype FloatT = Pcompf 166 | cmptype _ = Pcompi 167 | -- cmptype _ = panic $ "invalid argument type for comparison : " ++ show t 168 | 169 | transl Eq = Ceq 170 | transl Ne = Cne 171 | transl Le = Cle 172 | transl Ge = Cge 173 | transl Lt = Clt 174 | transl Gt = Cgt 175 | trans _ = panic $ "invalid operator for comparison : " ++ show op 176 | 177 | 178 | checkRecursive :: [Var] -> Lambda -> Bool 179 | checkRecursive = check_top 180 | where 181 | check_top idlist lam 182 | = case lam of 183 | Lvar v -> notElem v idlist 184 | Llet _ (v, e) cont -> 185 | check idlist e && check_top (add_let v e idlist) cont 186 | Lseq l1 l2 -> check idlist l1 && check_top idlist l2 187 | lam -> check idlist lam 188 | 189 | check idlist lam 190 | = case lam of 191 | Lvar _ -> True 192 | Llet _ (v, e) cont -> 193 | check idlist e && check (add_let v e idlist) cont 194 | Lletrec (v, e) cont -> 195 | check idlist e && check (add_let v e idlist) cont 196 | Lseq e1 e2 -> check idlist e1 && check idlist e2 197 | lam -> 198 | let fv = freeVars lam in 199 | all (`S.notMember` fv) idlist 200 | 201 | add_let id e idlist = 202 | let fv = freeVars e in 203 | if any (`S.member` fv) idlist 204 | then id : idlist 205 | else idlist 206 | 207 | {- Interfaces -} 208 | translLambda :: [LTcStmt] -> ChocoM Lambda 209 | translLambda stmts = evalStateT (translStmts stmts) () 210 | -------------------------------------------------------------------------------- /src/LamOpt.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module LamOpt ( 7 | optimizeLambda 8 | ) where 9 | 10 | import Choco 11 | import Id 12 | import LamSyn 13 | import Outputable 14 | import SrcLoc 15 | import Var 16 | 17 | import ArrayOpt 18 | import Contract 19 | import ElimLet 20 | 21 | {- Interface -} 22 | commandTable = [ 23 | ('l', simplifyLets), 24 | ('a', arrayOpt), 25 | ('i', doContract) 26 | ] 27 | 28 | optimizeLambda :: String -> Lambda -> ChocoM Lambda 29 | optimizeLambda [] lam = return lam 30 | optimizeLambda (c:rem) lam = case lookup c commandTable of 31 | Just m -> do lam' <- m lam 32 | optimizeLambda rem lam' 33 | Nothing -> simpleError (text "unknown optimization command: " <> char c) 34 | -------------------------------------------------------------------------------- /src/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | ------------------------------------------------- 3 | -- Choco -- 4 | -- Chikadzume Oriented Compiler -- 5 | -- Copyright 2007-2008 by Basement fairy -- 6 | ------------------------------------------------- 7 | module Lexer ( 8 | Token(..), lexer, lexToken, 9 | P(..), PResult(..), runP, 10 | failLocMsgP 11 | ) where 12 | import Var 13 | import SrcLoc 14 | import qualified Data.Map as M 15 | import Panic 16 | 17 | import Debug.Trace 18 | 19 | {- MinCaml lexer -} 20 | } 21 | 22 | $blank = [\ \t\n\r] 23 | $lowercase = [a-z\_] 24 | $uppercase = [A-Z] 25 | $identchar = [A-Z a-z\_\'0-9] 26 | $symbolchar = [\!\*\+\-\.\/\<\=\>\|] 27 | 28 | @decimal_literal = [0-9] [0-9\_]* 29 | @int_literal = @decimal_literal 30 | 31 | @float_literal = [0-9] [0-9\_]* 32 | (\. [0-9\_]*)? 33 | ([eE] [\+\-]? [0-9] [0-9\_]*)? 34 | 35 | mincaml :- 36 | 37 | $blank+ ; 38 | "(*" { nested_comment } 39 | 40 | "_" { token Tunderscore } 41 | 42 | $lowercase $identchar* { strtoken $ scanWord } 43 | @int_literal { strtoken (Tint . read) } 44 | @float_literal { strtoken Tfloat } 45 | 46 | "-" { token Tminus } 47 | "+" { token Tplus } 48 | "*" { token Ttimes } 49 | "/" { token Tdiv } 50 | "-." { token Tminusdot } 51 | "+." { token Tplusdot } 52 | "*." { token Tastdot } 53 | "/." { token Tslashdot } 54 | "=" { token Tequal } 55 | "<>" { token Tnotequal } 56 | "<=" { token Tlessequal } 57 | ">=" { token Tgreaterequal } 58 | "<" { token Tless } 59 | ">" { token Tgreater } 60 | "," { token Tcomma } 61 | "." { token Tdot } 62 | ";" { token Tsemi } 63 | ";;" { token Tsemisemi } 64 | "(" { token Tlparen } 65 | ")" { token Trparen } 66 | "<-" { token Tlessminus } 67 | 68 | 69 | { 70 | ------------------------------------------------------------ 71 | -- The Token type 72 | ------------------------------------------------------------ 73 | 74 | data Token 75 | -- reserved words 76 | = Ttrue | Tfalse 77 | | Tif | Tthen | Telse 78 | | Tlet | Trec | Tin 79 | 80 | -- symbols 81 | | Tunderscore | Tminus | Tplus | Ttimes | Tdiv 82 | | Tminusdot | Tplusdot | Tastdot | Tslashdot 83 | | Tequal | Tnotequal | Tlessequal | Tgreaterequal 84 | | Tless | Tgreater 85 | | Tcomma | Tdot | Tsemi | Tsemisemi | Tlparen | Trparen | Tlessminus 86 | 87 | -- basic data types 88 | | Tident Name 89 | | Tint Int 90 | | Tfloat String 91 | 92 | | Teof 93 | deriving (Eq, Show) 94 | 95 | reservedWords = M.fromList 96 | [ ("true", Ttrue) 97 | , ("false", Tfalse) 98 | , ("let", Tlet) 99 | , ("rec", Trec) 100 | , ("in", Tin) 101 | , ("if", Tif) 102 | , ("then", Tthen) 103 | , ("else", Telse) 104 | ] 105 | 106 | scanWord str = 107 | case M.lookup str reservedWords of 108 | Just tok -> tok 109 | Nothing -> Tident . mkName $ str 110 | 111 | ------------------------------------------------------------ 112 | -- The Parse monad 113 | ------------------------------------------------------------ 114 | 115 | data PState = PState { 116 | current_pos :: !SrcLoc, -- position at current input location 117 | input_string :: String, -- the current input 118 | prev_char :: !Char, -- the character before the input 119 | startcode :: !Int -- the current startcode 120 | } 121 | 122 | data PResult a = POk PState a 123 | | PFailed SrcLoc String -- error message 124 | 125 | data P a = P { unP :: PState -> PResult a } 126 | 127 | runP :: String -> P a -> PResult a 128 | runP input p = (unP p) (PState{ 129 | current_pos = startSrcLoc, 130 | input_string = input, 131 | prev_char = '\n', 132 | startcode = 0}) 133 | 134 | instance Monad P where 135 | return a = P $ \s -> POk s a 136 | (P m) >>= k = P $ \s -> 137 | case m s of 138 | POk s' a -> (unP (k a)) s' 139 | PFailed pos err -> PFailed pos err 140 | fail = failP 141 | 142 | failP :: String -> P a 143 | failP msg = P $ \s -> PFailed (current_pos s) msg 144 | 145 | failLocMsgP :: SrcLoc -> String -> P a 146 | failLocMsgP loc msg = P $ \s -> PFailed loc msg 147 | 148 | data AlexInput = AI !SrcLoc 149 | String -- input 150 | !Char -- prevous char 151 | Int -- start code 152 | 153 | alexGetChar :: AlexInput -> Maybe (Char,AlexInput) 154 | alexGetChar (AI _ [] _ _) = Nothing 155 | alexGetChar (AI loc (c:cs) _ i) = 156 | let loc' = advanceSrcLoc loc c 157 | in Just (c, AI loc' cs c i) 158 | 159 | alexInputPrevChar :: AlexInput -> Char 160 | alexInputPrevChar (AI _ _ c _) = c 161 | 162 | getInput :: P AlexInput 163 | getInput = P $ \s@(PState loc inp prev code) -> POk s (AI loc inp prev code) 164 | 165 | setInput :: AlexInput -> P () 166 | setInput (AI loc inp prev code) = P $ \s -> 167 | POk s{ current_pos = loc, 168 | input_string = inp, 169 | prev_char = prev, 170 | startcode = code } () 171 | 172 | lexToken :: P (Located Token) 173 | lexToken = do 174 | inp@(AI loc input _ code) <- getInput 175 | case alexScan inp code of 176 | AlexEOF -> return $ L loc Teof 177 | AlexError (AI loc' _ _ _) -> failLocMsgP loc' "lexical error" 178 | AlexSkip inp2 _ -> do setInput inp2; lexToken 179 | AlexToken inp2 len action -> do 180 | setInput inp2 181 | action loc input len 182 | 183 | lexer :: (Located Token -> P a) -> P a 184 | lexer cont = do 185 | tok@(L _ tok_) <- lexToken 186 | -- trace ("token: " ++ show tok_) $ do 187 | cont tok 188 | 189 | ------------------------------------------------------------ 190 | -- Lexer actions 191 | ------------------------------------------------------------ 192 | 193 | type Action = SrcLoc -> String -> Int -> P (Located Token) 194 | 195 | token :: Token -> Action 196 | token t loc _ _ = return $ L loc t 197 | 198 | strtoken :: (String -> Token) -> Action 199 | strtoken f loc inp len = return $ L loc (f (take len inp)) 200 | 201 | 202 | nested_comment :: Action 203 | nested_comment loc inp len = do 204 | input <- getInput 205 | go 1 input 206 | where 207 | go 0 input = do setInput input; lexToken 208 | go n input = do 209 | case alexGetChar input of 210 | Nothing -> err input 211 | Just (c,input) -> do 212 | case c of 213 | '*' -> do case alexGetChar input of 214 | Nothing -> err input 215 | Just (')',input) -> go (n-1) input 216 | Just (c,_) -> go n input 217 | '(' -> do case alexGetChar input of 218 | Nothing -> err input 219 | Just ('*',input') -> go (n+1) input' 220 | Just (c,input) -> go n input 221 | c -> go n input 222 | err (AI loc _ _ _) = failLocMsgP loc "unterminated `(*'" 223 | } 224 | 225 | -------------------------------------------------------------------------------- /src/LibLex.x: -------------------------------------------------------------------------------- 1 | { 2 | ------------------------------------------------- 3 | -- Choco -- 4 | -- Chikadzume Oriented Compiler -- 5 | -- Copyright 2007-2008 by Basement fairy -- 6 | ------------------------------------------------- 7 | module LibLex where 8 | 9 | import Var 10 | import SrcLoc 11 | import Panic 12 | 13 | import Debug.Trace 14 | import qualified Data.Map as M 15 | } 16 | 17 | $blank = [\ \t\n\r] 18 | $lowercase = [a-z\_] 19 | $uppercase = [A-Z] 20 | $identchar = [A-Z a-z\_\'0-9] 21 | $symbolchar = [\!\*\+\-\.\/\<\=\>\|] 22 | 23 | @decimal_literal = [0-9] [0-9\_]* 24 | @int_literal = @decimal_literal 25 | 26 | @float_literal = [0-9] [0-9\_]* 27 | (\. [0-9\_]*)? 28 | ([eE] [\+\-]? [0-9] [0-9\_]*)? 29 | 30 | libcmm :- 31 | 32 | $blank+ ; 33 | 34 | $lowercase $identchar* { strtoken $ scanWord } 35 | @int_literal { strtoken (Tint . read) } 36 | @float_literal { strtoken Tfloat } 37 | 38 | "=" { token Tequal } 39 | "-" { token Tminus } 40 | "+" { token Tplus } 41 | "*" { token Ttimes } 42 | "/" { token Tdiv } 43 | "-." { token Tminusdot } 44 | "+." { token Tplusdot } 45 | "*." { token Tastdot } 46 | "/." { token Tslashdot } 47 | "==" { token Tequalequal } 48 | "<>" { token Tnotequal } 49 | "<=" { token Tlessequal } 50 | ">=" { token Tgreaterequal } 51 | "<" { token Tless } 52 | ">" { token Tgreater } 53 | "==." { token Tequalequaldot } 54 | "<>." { token Tnotequaldot } 55 | "<=." { token Tlessequaldot } 56 | ">=." { token Tgreaterequaldot } 57 | "<." { token Tlessdot } 58 | ">." { token Tgreaterdot } 59 | ";" { token Tsemi } 60 | "(" { token Tlparen } 61 | ")" { token Trparen } 62 | 63 | { 64 | ------------------------------------------------------------ 65 | -- The Token type 66 | ------------------------------------------------------------ 67 | data Token 68 | -- reserved words 69 | = Tfunction | Tcall | Tif | Tlet_const | Tin 70 | 71 | -- symbols 72 | | Tequal | Tminus | Tplus | Ttimes | Tdiv 73 | | Tminusdot | Tplusdot | Tastdot | Tslashdot 74 | | Tequalequal | Tnotequal | Tlessequal | Tgreaterequal | Tless | Tgreater 75 | | Tequalequaldot | Tnotequaldot | Tlessequaldot | Tgreaterequaldot 76 | | Tlessdot | Tgreaterdot | Tsemi | Tlparen | Trparen 77 | 78 | -- basic data types 79 | | Tident String 80 | | Tint Int 81 | | Tfloat String 82 | 83 | | Teof 84 | deriving (Eq, Show) 85 | 86 | reservedWords = M.fromList 87 | [ ("function", Tfunction) 88 | , ("call", Tcall) 89 | , ("if", Tif) 90 | , ("let_const", Tlet_const) 91 | , ("in", Tin) 92 | ] 93 | 94 | scanWord str = case M.lookup str reservedWords of 95 | Just tok -> tok 96 | Nothing -> Tident str 97 | 98 | ------------------------------------------------------------ 99 | -- The Parse monad 100 | ------------------------------------------------------------ 101 | 102 | data PState = PState { 103 | current_pos :: !SrcLoc, -- position at current input location 104 | input_string :: String, -- the current input 105 | prev_char :: !Char, -- the character before the input 106 | startcode :: !Int -- the current startcode 107 | } 108 | 109 | data PResult a = POk PState a 110 | | PFailed SrcLoc String -- error message 111 | 112 | data P a = P { unP :: PState -> PResult a } 113 | 114 | runP :: String -> P a -> PResult a 115 | runP input p = (unP p) (PState{ 116 | current_pos = startSrcLoc, 117 | input_string = input, 118 | prev_char = '\n', 119 | startcode = 0}) 120 | 121 | instance Monad P where 122 | return a = P $ \s -> POk s a 123 | (P m) >>= k = P $ \s -> 124 | case m s of 125 | POk s' a -> (unP (k a)) s' 126 | PFailed pos err -> PFailed pos err 127 | fail = failP 128 | 129 | failP :: String -> P a 130 | failP msg = P $ \s -> PFailed (current_pos s) msg 131 | 132 | failLocMsgP :: SrcLoc -> String -> P a 133 | failLocMsgP loc msg = P $ \s -> PFailed loc msg 134 | 135 | data AlexInput = AI !SrcLoc 136 | String -- input 137 | !Char -- prevous char 138 | Int -- start code 139 | 140 | alexGetChar :: AlexInput -> Maybe (Char,AlexInput) 141 | alexGetChar (AI _ [] _ _) = Nothing 142 | alexGetChar (AI loc (c:cs) _ i) = 143 | let loc' = advanceSrcLoc loc c 144 | in Just (c, AI loc' cs c i) 145 | 146 | alexInputPrevChar :: AlexInput -> Char 147 | alexInputPrevChar (AI _ _ c _) = c 148 | 149 | getInput :: P AlexInput 150 | getInput = P $ \s@(PState loc inp prev code) -> POk s (AI loc inp prev code) 151 | 152 | setInput :: AlexInput -> P () 153 | setInput (AI loc inp prev code) = P $ \s -> 154 | POk s{ current_pos = loc, 155 | input_string = inp, 156 | prev_char = prev, 157 | startcode = code } () 158 | 159 | lexToken :: P (Located Token) 160 | lexToken = do 161 | inp@(AI loc input _ code) <- getInput 162 | case alexScan inp code of 163 | AlexEOF -> return $ L loc Teof 164 | AlexError (AI loc' _ _ _) -> failLocMsgP loc' "lexical error" 165 | AlexSkip inp2 _ -> do setInput inp2; lexToken 166 | AlexToken inp2 len action -> do 167 | setInput inp2 168 | action loc input len 169 | 170 | lexer :: (Located Token -> P a) -> P a 171 | lexer cont = do 172 | tok@(L _ tok_) <- lexToken 173 | trace ("token: " ++ show tok_) $ do 174 | cont tok 175 | 176 | ------------------------------------------------------------ 177 | -- Lexer actions 178 | ------------------------------------------------------------ 179 | 180 | type Action = SrcLoc -> String -> Int -> P (Located Token) 181 | 182 | token :: Token -> Action 183 | token t loc _ _ = return $ L loc t 184 | 185 | strtoken :: (String -> Token) -> Action 186 | strtoken f loc inp len = return $ L loc (f (take len inp)) 187 | } 188 | -------------------------------------------------------------------------------- /src/LibParse.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# OPTIONS_GHC -w #-} 3 | ------------------------------------------------- 4 | -- Choco -- 5 | -- Chikadzume Oriented Compiler -- 6 | -- Copyright 2007-2008 by Basement fairy -- 7 | ------------------------------------------------- 8 | module LibParse (parseLib) where 9 | 10 | import Choco 11 | import Const 12 | import LamSyn 13 | import LibLex 14 | import Primitive 15 | import SrcLoc 16 | import Var 17 | 18 | import Control.Monad 19 | import qualified Data.Map as M 20 | 21 | {- The parser for library -} 22 | } 23 | 24 | %token 25 | '=' { L _ Tequal } 26 | '-' { L _ Tminus } 27 | '+' { L _ Tplus } 28 | '*' { L _ Ttimes } 29 | '/' { L _ Tdiv } 30 | '-.' { L _ Tminusdot } 31 | '+.' { L _ Tplusdot } 32 | '*.' { L _ Tastdot } 33 | '/.' { L _ Tslashdot } 34 | '==' { L _ Tequalequal } 35 | '<>' { L _ Tnotequal } 36 | '<=' { L _ Tlessequal } 37 | '>=' { L _ Tgreaterequal } 38 | '<' { L _ Tless } 39 | '>' { L _ Tgreater } 40 | '==.' { L _ Tequalequaldot } 41 | '<>.' { L _ Tnotequaldot } 42 | '<=.' { L _ Tlessequaldot } 43 | '>=.' { L _ Tgreaterequaldot } 44 | '<.' { L _ Tlessdot } 45 | '>.' { L _ Tgreaterdot } 46 | ';' { L _ Tsemi } 47 | '(' { L _ Tlparen } 48 | ')' { L _ Trparen } 49 | 50 | 'function' { L _ Tfunction } 51 | 'call' { L _ Tcall } 52 | 'if' { L _ Tif } 53 | 'let_const' { L _ Tlet_const } 54 | 'in' { L _ Tin } 55 | 56 | ident { L _ (Tident _) } 57 | int { L _ (Tint _) } 58 | float { L _ (Tfloat _) } 59 | 60 | eof { L _ Teof } 61 | 62 | %monad { P } { >>= } { return } 63 | %lexer { lexer } { L _ Teof } 64 | %tokentype { Located Token } 65 | %name parse fundecls 66 | 67 | %nonassoc 'let_const' 68 | %nonassoc ';' 69 | %left '==' '<>' '<' '>' '<=' '>=' '==.' '<>.' '<=.' '>=.' '<.' '>.' 70 | %left '+' '-' '+.' '-.' 71 | %left '*' '/' '*.' '/.' 72 | %nonassoc prec_unary_minus 73 | %% 74 | 75 | fundecls :: { [ (Var, Lambda) ] } 76 | : { [] } 77 | | fundecls fundecl { $2 : $1 } 78 | 79 | fundecl :: { (Var, Lambda) } 80 | : 'function' ident '(' params ')' '(' lam ')' 81 | { (makeVar $2, Lfun (reverse $4) $7 ) } 82 | 83 | params :: { [Var] } 84 | : { [] } 85 | | params ident { makeVar $2 : $1 } 86 | 87 | 88 | lam :: { Lambda } 89 | : simple_lam { $1 } 90 | | simple_lam simple_lam_list { makeApp $1 (reverse $2) } 91 | | 'let_const' ident '=' lam 'in' lam 92 | { Llet Strict (makeVar $2, $4) $6 } 93 | | 'if' simple_lam simple_lam simple_lam { Lcond $2 $3 $4 } 94 | | '-' lam %prec prec_unary_minus { makeNeg $2 } 95 | | '-.' lam %prec prec_unary_minus { makeFNeg $2 } 96 | 97 | constant :: { Const } 98 | : int { makeIntC $1 } 99 | | float { makeFloatC $1 } 100 | 101 | simple_lam :: { Lambda } 102 | : ident { Lvar (makeVar $1) } 103 | | constant { Llit $1 } 104 | | '(' seq_lam ')' { $2 } 105 | 106 | simple_lam_list :: { [Lambda] } 107 | : simple_lam { [$1] } 108 | | simple_lam_list simple_lam { $2 : $1 } 109 | 110 | seq_lam :: { Lambda } 111 | : lam { $1 } 112 | | lam ';' { $1 } 113 | | lam ';' seq_lam { Lseq $1 $3 } 114 | | lam '+' lam { Lprim Paddi [$1, $3] } 115 | | lam '-' lam { Lprim Psubi [$1, $3] } 116 | | lam '*' lam { Lprim Pmuli [$1, $3] } 117 | | lam '/' lam { Lprim Pdivi [$1, $3] } 118 | | lam '+.' lam { Lprim Paddf [$1, $3] } 119 | | lam '-.' lam { Lprim Psubf [$1, $3] } 120 | | lam '*.' lam { Lprim Pmulf [$1, $3] } 121 | | lam '/.' lam { Lprim Pdivf [$1, $3] } 122 | | lam '==' lam { Lprim (Pcompi Ceq) [$1, $3] } 123 | | lam '<>' lam { Lprim (Pcompi Cne) [$1, $3] } 124 | | lam '<' lam { Lprim (Pcompi Clt) [$1, $3] } 125 | | lam '>' lam { Lprim (Pcompi Cgt) [$1, $3] } 126 | | lam '<=' lam { Lprim (Pcompi Cle) [$1, $3] } 127 | | lam '>=' lam { Lprim (Pcompi Cge) [$1, $3] } 128 | | lam '==.' lam { Lprim (Pcompf Ceq) [$1, $3] } 129 | | lam '<>.' lam { Lprim (Pcompf Cne) [$1, $3] } 130 | | lam '<.' lam { Lprim (Pcompf Clt) [$1, $3] } 131 | | lam '>.' lam { Lprim (Pcompf Cgt) [$1, $3] } 132 | | lam '<=.' lam { Lprim (Pcompf Cle) [$1, $3] } 133 | | lam '>=.' lam { Lprim (Pcompf Cge) [$1, $3] } 134 | 135 | 136 | { 137 | makeVar (L _ (Tident x)) = Var{ var_name = x } 138 | makeIntC (L _ (Tint n)) = IntC n 139 | makeFloatC (L _ (Tfloat f)) = FloatC (read f) 140 | 141 | makeApp (Lvar f) args = 142 | let (_, lm) = primTable in 143 | case M.lookup (var_name f) lm of 144 | Just fn -> fn args 145 | Nothing -> Lapp (Lvar f) args True 146 | 147 | makeNeg (Llit (IntC n)) = Llit (IntC (-n)) 148 | makeNeg e = Lprim Pnegi [e] 149 | 150 | makeFNeg (Llit (FloatC f)) = Llit (FloatC (-f)) 151 | makeFNeg e = Lprim Pnegf [e] 152 | 153 | happyError :: P a 154 | happyError = fail "parse error" 155 | 156 | {- external interface -} 157 | parseLib :: String -> Lambda -> ChocoM Lambda 158 | parseLib src cont = do 159 | case runP src parse of 160 | POk _ fundecls -> do 161 | runIO$print$ fundecls 162 | fundecls' <- mapM t' ident '=' lam 'in' lam 163 | { Llet Strict (makeVar $2, $3) $4 } 164 | ename fundecls 165 | return $ foldr (\(v, l) cont -> Llet Strict (v, l) cont) 166 | cont fundecls' 167 | PFailed loc msg -> 168 | compileError (text msg) loc 169 | where 170 | rename (v, Lfun params body) 171 | = do vid <- newUniq 172 | paramsid <- replicateM (length params) newUniq 173 | let tbl = M.fromList $ zip (map var_name (v:params)) (vid:paramsid) 174 | body' <- walk tbl body 175 | let v' = v{ var_id = vid } 176 | let params' = zipWith (\p i -> p{ var_id = i }) params paramsid 177 | return (v', Lfun params' body') 178 | walk m (Lvar v) = return $ Lvar v 179 | walk m lam = return lam 180 | } 181 | -------------------------------------------------------------------------------- /src/Libraries.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Libraries (addLib) where 7 | 8 | import Choco 9 | import Const 10 | import LamSyn 11 | import Primitive 12 | import Types 13 | import Var 14 | import Prelude hiding ((+), (-), (>), (<), (<=), (>=), (==)) 15 | 16 | import Control.Monad 17 | import qualified Data.Map as M 18 | 19 | addLib :: Lambda -> ChocoM Lambda 20 | addLib cont = do 21 | -- floor 22 | a <- mkTmpVar "a" (toScheme FloatT) 23 | f <- mkTmpVar "f" (toScheme FloatT) 24 | let fun = Lfun [f] (Llet Strict (a, Lprim Pitof [Lprim Pftoi [Lvar f]]) (Lcond (Lprim (Pcompf Clt) [Lvar f, Llit (FloatC 0.0)]) 25 | (Lcond (Lprim (Pcompf Ceq) [Lvar f, Lvar a]) (Lvar a) 26 | (Lprim Psubf [Lvar a, Llit (FloatC 1.0)])) 27 | (Lvar a))) 28 | 29 | let name = getPrimVar "floor" 30 | let f1 = Llet Strict (name, fun) 31 | 32 | -- atan 33 | myatan_k <- mkGlobalVar "myatan_k" (toScheme (FunT [FloatT] FloatT)) 34 | x <- mkTmpVar "x" (toScheme FloatT) 35 | z <- mkTmpVar "z" (toScheme FloatT) 36 | w <- mkTmpVar "w" (toScheme FloatT) 37 | 38 | let fun = Lfun [x] (Llet Strict (z, var x *. var x) (Llet Strict (w, var z *. var z) ((var z *. (int 0x3eaaaaaa +. (var w *. (int 0x3e124925 +. (var w *. (int 0x3dba2e6e +. (var w *. (int 0x3d886b35 +. (var w *. (int 0x3d4bda59 +. (var w *. int 0x3c8569d7))))))))))) +. (var w *. (int 0xbe4ccccd +. (var w *. (int 0xbde38e38 +. (var w *. (int 0xbd9d8795 +. (var w *. (int 0xbd6ef16b +. (var w *. int 0xbd15a221)))))))))))) 39 | 40 | let f2 = f1 . Llet Strict (myatan_k, fun) 41 | 42 | x <- mkTmpVar "x" (toScheme FloatT) 43 | ix <- mkTmpVar "ix" (toScheme FloatT) 44 | nx <- mkTmpVar "nx" (toScheme FloatT) 45 | [z1, z2, z3, z4] <- replicateM 4 (mkTmpVar "z" (toScheme FloatT)) 46 | let fun = Lfun [x] (Llet Strict (ix, fabs (var x)) (Lcond (var ix >= int 0x50800000) (Lcond (var x <. float 0.0) (int 0xbfc90fdb) (int 0x3fc90fdb)) (Lcond (var ix < int 0x31000000) (var x) (Lcond (var ix < int 0x3ee00000) (var x -. (var x *. (Lapp (Lvar myatan_k) [var x] True))) (Llet Variable (nx, fabs (var x)) (Lcond (var ix < int 0x3f300000) (Lseq (Lassign nx (((float 2.0 *. var nx) -. float 1.0) /. (float 2.0 +. var nx))) (Llet Strict (z1, int 0x3eed6338 -. (((var nx *. (Lapp (Lvar myatan_k) [var nx] True)) -. int 0x31ac3769) -. var nx)) (Lcond (var nx < int 0) (fneg (var z1)) (var z1)))) (Lcond (var ix < int 0x3f980000) (Lseq (Lassign nx ((var nx -. float 1.0) /. (var nx +. float 1.0))) (Llet Strict (z2, int 0x3f490fda -. (((var nx *. (Lapp (Lvar myatan_k) [var nx] True)) -. int 0x33222168) -. var nx)) (Lcond (var nx < int 0) (fneg (var z2)) (var z2)))) (Lcond (var ix < int 0x401c0000) (Lseq (Lassign nx ((var x -. float 1.5) /. (float 1.0 +. (float 1.5 *. var nx)))) (Llet Strict (z3, int 0x3f7b985e -. (((var nx *. (Lapp (Lvar myatan_k) [var nx] True)) -. int 0x33140fb4) -. var nx)) (Lcond (var nx < int 0) (fneg (var z3)) (var z3)))) (Lseq (Lassign nx (fneg (float 1.0 /. var x))) (Llet Strict (z4, int 0x3fc90fda -. (((var nx *. (Lapp (Lvar myatan_k) [var nx] True)) -. int 0x33a22168) -. var nx)) (Lcond (var nx < int 0) (fneg (var z)) (var z)))))))))))) 47 | 48 | 49 | let name = getPrimVar "atan" 50 | let f3 = f2 . Llet Strict (name, fun) 51 | 52 | j <- mkTmpVar "j" (toScheme UnknownT) 53 | i <- mkTmpVar "i" (toScheme UnknownT) 54 | l <- mkTmpVar "l" (toScheme UnknownT) 55 | k <- mkTmpVar "k" (toScheme UnknownT) 56 | let fun = Lfun [i] (Llet Strict (j, var i - (fabs (var i))) (Llet Strict (k, Lcond (var i > int 0) (var i) (int 0 - var i)) (Llet Strict (l, (var k + int 0x4b000000) -. int 0x4b000000) (Lcond (var k > int 0x00800000) (int 0) (var j - var l))))) 57 | let name = getPrimVar "float_of_int" 58 | let f4 = f3 . Llet Strict (name, fun) 59 | 60 | g <- mkTmpVar "g" (toScheme UnknownT) 61 | f <- mkTmpVar "f" (toScheme UnknownT) 62 | h <- mkTmpVar "h" (toScheme UnknownT) 63 | let fun = Lfun [f] (Llet Strict (g, fabs (var f)) (Lcond (var g > int 0x4b000000) (int 0) (Llet Strict (h, (var g +. int 0x4b000000) - int 0x4b000000) (Lcond (var f <= int 0) (int 0 - var h) (var h))))) 64 | let name = getPrimVar "int_of_float" 65 | let f5 = f4 . Llet Strict (name, fun) 66 | 67 | v <- mkTmpVar "value" (toScheme UnknownT) 68 | t <- mkTmpVar "tmp" (toScheme UnknownT) 69 | i <- mkTmpVar "i" (toScheme IntT) 70 | a <- mkTmpVar "a" (toScheme UnknownT) 71 | let fun = Lfun [a] (Llet Variable (v, int 0) (Llet Variable (t, int (-1)) (Lseq (Lfor i (int 0) (int 3) (Lseq (Lassign t (int (-1))) (Lseq (Lwhile (var t < int 0) (Lassign t (Lprim Pget []))) (Lcond (var i == int 0) (Lassign v (var t)) (Lassign v ((var v << int 8) + var t)))))) (var v)))) 72 | 73 | -- I/O 74 | read <- mkGlobalVar "read" (toScheme (FunT [UnitT] UnknownT)) 75 | let name1 = getPrimVar "read_int" 76 | let name2 = getPrimVar "read_float" 77 | let f6 = f5 . Llet Strict (read, fun) . Llet Strict (name1, Lvar read) . Llet Strict (name2, Lvar read) 78 | 79 | -- sin/cos 80 | k_sin <- mkGlobalVar "k_sin" (toScheme (FunT [FloatT] FloatT)) 81 | x <- mkTmpVar "x" (toScheme UnknownT) 82 | y <- mkTmpVar "y" (toScheme UnknownT) 83 | let fun = Lfun [x] (Llet Strict (y, var x *. var x) (var x *. (float 1.0 +. (var y *. (int 0xbe2aaaab +. (var y *. (int 0x3c088889 +. (var y *. (int 0xb9500d01 +. (var y *. (int 0x3638ef1b +. (var y *. (int 0xb2d72f34 +. (var y *. int 0x2f2ec9d3)))))))))))))) 84 | let f7 = f6 . Llet Strict (k_sin, fun) 85 | 86 | k_cos <- mkGlobalVar "k_cos" (toScheme (FunT [FloatT] FloatT)) 87 | x <- mkTmpVar "x" (toScheme UnknownT) 88 | y <- mkTmpVar "y" (toScheme UnknownT) 89 | let fun = Lfun [x] (Llet Strict (y, var x *. var x) (float 1.0 +. (var y *. (int 0xbf000000 +. (var y *. (int 0x3d2aaaab +. (var y *. (int 0xbab60b61 +. (var y *. (int 0x37d00d01 +. (var y *. (int 0xb493f27c +. (var y *. (int 0x310f74f6 +. (var y *. int 0xad47d743))))))))))))))) 90 | let f8 = f7 . Llet Strict (k_cos, fun) 91 | 92 | reduction <- mkGlobalVar "reduction" (toScheme (FunT [FloatT] FloatT)) 93 | x <- mkTmpVar "x" (toScheme FloatT) 94 | t <- mkTmpVar "t" (toScheme FloatT) 95 | r <- mkTmpVar "r" (toScheme FloatT) 96 | let fun = Lfun [x] (Llet Variable (t, fabs (var x)) (Llet Variable (r, int 0) (Lseq (Lwhile (var t >. int 0x3f490fdb) (Lseq (Lassign t (var t -. int 0x3fc90fdb)) (Lassign r (Lcond (var r < int 3) (var r + int 1) (int 0))))) (Lprim PcreateTuple [var t, var r])))) 97 | let f9 = f8 . Llet Strict (reduction, fun) 98 | 99 | a <- mkTmpVar "a" (toScheme UnknownT) 100 | t <- mkTmpVar "t" (toScheme UnknownT) 101 | r <- mkTmpVar "r" (toScheme UnknownT) 102 | x <- mkTmpVar "x" (toScheme UnknownT) 103 | 104 | let fun = Lfun [a] (Llet Strict (x, Lapp (Lvar reduction) [var a] True) (Llet Strict (t, Lprim (PtupleRef 0) [Lvar x]) (Llet Strict (r, Lprim (PtupleRef 1) [Lvar x]) (Lcond (var r == int 0) (Lapp (Lvar k_cos) [var t] True) (Lcond (var r == int 1) (fneg (Lapp (Lvar k_sin) [var t] True)) (Lcond (var r == int 2) (fneg (Lapp (Lvar k_cos) [var t] True)) (Lapp (Lvar k_sin) [var t] True))))))) 105 | let name = getPrimVar "cos" 106 | let f10 = f9 . Llet Strict (name, fun) 107 | 108 | a <- mkTmpVar "a" (toScheme UnknownT) 109 | t <- mkTmpVar "t" (toScheme UnknownT) 110 | r <- mkTmpVar "r" (toScheme UnknownT) 111 | x <- mkTmpVar "x" (toScheme UnknownT) 112 | tmp <- mkTmpVar "tmp" (toScheme UnknownT) 113 | let fun = Lfun [a] (Llet Strict (x, Lapp (Lvar reduction) [var a] True) (Llet Strict (t, Lprim (PtupleRef 0) [Lvar x]) (Llet Strict (r, Lprim (PtupleRef 1) [Lvar x]) (Llet Strict (tmp, Lcond (var r == int 0) (Lapp (Lvar k_sin) [var t] True) (Lcond (var r == int 1) (Lapp (Lvar k_cos) [var t] True) (Lcond (var r == int 2) (fneg (Lapp (Lvar k_sin) [var t] True)) (fneg (Lapp (Lvar k_cos) [var t] True))))) (Lcond (var a < int 0) (fneg (var tmp)) (var tmp)))))) 114 | let name = getPrimVar "sin" 115 | let f11 = f10 . Llet Strict (name, fun) 116 | 117 | return (f11 cont) 118 | 119 | e1 + e2 = Lprim Paddi [e1, e2] 120 | e1 - e2 = Lprim Psubi [e1, e2] 121 | e1 +. e2 = Lprim Paddf [e1, e2] 122 | e1 -. e2 = Lprim Psubf [e1, e2] 123 | e1 *. e2 = Lprim Pmulf [e1, e2] 124 | e1 /. e2 = Lprim Pdivf [e1, e2] 125 | e1 <. e2 = Lprim (Pcompf Clt) [e1, e2] 126 | e1 >. e2 = Lprim (Pcompf Cgt) [e1, e2] 127 | e1 < e2 = Lprim (Pcompi Clt) [e1, e2] 128 | e1 > e2 = Lprim (Pcompi Cgt) [e1, e2] 129 | e1 <= e2 = Lprim (Pcompi Cle) [e1, e2] 130 | e1 >= e2 = Lprim (Pcompi Cge) [e1, e2] 131 | e1 == e2 = Lprim (Pcompi Ceq) [e1, e2] 132 | e1 << e2 = Lprim Plsl [e1, e2] 133 | int n = Llit (IntC n) 134 | float f = Llit (FloatC f) 135 | var v = Lvar v 136 | fabs a = Lprim Pabsf [a] 137 | fneg a = Lprim Pnegf [a] 138 | 139 | getPrimVar :: String -> Var 140 | getPrimVar name = 141 | let (ty, id, _) = (fst primTable) M.! (mkName name) 142 | in mkVar name id ty True 143 | -------------------------------------------------------------------------------- /src/Linearize.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Linearize ( 7 | Label, Inst(..), InstDesc(..), 8 | consInst, consNop, endInst, 9 | hasFallthrough, 10 | FunDec(..), 11 | fundecl 12 | ) where 13 | 14 | import Choco 15 | import Id 16 | import Reg 17 | import qualified Mach as M 18 | import qualified CmmSyn as Cmm 19 | import qualified Data.Set as S 20 | import Outputable 21 | import Panic 22 | 23 | import Control.Monad.State 24 | 25 | type Label = Int 26 | 27 | data Inst = Inst { 28 | idesc :: InstDesc, 29 | result :: [Reg], 30 | args :: [Reg], 31 | live :: S.Set Reg, 32 | next :: Inst 33 | } 34 | deriving (Eq, Show) 35 | 36 | {- for test -} 37 | 38 | data InstDesc 39 | = Lend 40 | | Lop M.Operation 41 | | Lnop 42 | | Lreturn 43 | | Llabel Label 44 | | Lbranch Label 45 | | Lcondbranch M.Test Label 46 | deriving (Eq, Show) 47 | 48 | instance Outputable Inst where 49 | ppr i = case idesc i of 50 | Lend -> empty 51 | Lop op -> M.pprOp op (result i) (args i) $$ ppr (next i) 52 | Lnop -> text "nop" $$ ppr (next i) 53 | Lreturn -> text "return" $$ ppr (next i) 54 | Llabel lbl -> 55 | text "===" <+> text "label-" <> int lbl <+> text "==" 56 | $$ ppr (next i) 57 | Lbranch lbl -> text "branch" <+> text "lablel-" <> int lbl $$ ppr (next i) 58 | Lcondbranch t lbl -> 59 | hang (text "if" <+> M.pprTest t (args i)) 2 60 | (text "jump" <+> text "label-" <> int lbl) 61 | $$ ppr (next i) 62 | 63 | newLabel = lift $ newUniq 64 | 65 | getLabel inst = case idesc inst of 66 | Lbranch lbl -> return (lbl, inst) 67 | Llabel lbl -> return (lbl, inst) 68 | Lend -> return (-1, inst) 69 | _ -> do 70 | lbl <- newLabel 71 | return (lbl, consSimpleInst (Llabel lbl) inst) 72 | 73 | hasFallthrough inst 74 | = case inst of 75 | Lreturn -> False 76 | Lbranch _ -> False 77 | Lop M.Itailcall_ind -> False 78 | Lop (M.Itailcall_imm _) -> False 79 | _ -> True 80 | 81 | endInst = Inst { 82 | idesc = Lend, 83 | result = [], 84 | args = [], 85 | live = S.empty, 86 | next = endInst 87 | } 88 | 89 | consNop n = Inst { 90 | idesc = Lnop, 91 | result = [], 92 | args = [], 93 | live = S.empty, 94 | next = n 95 | } 96 | 97 | consInst d r a n = Inst { 98 | idesc = d, 99 | result = r, 100 | args = a, 101 | live = S.empty, 102 | next = n 103 | } 104 | 105 | consSimpleInst d n = Inst { 106 | idesc = d, 107 | result = [], 108 | args = [], 109 | live = S.empty, 110 | next = n 111 | } 112 | 113 | data FunDec = FunDec { 114 | fun_name :: String, 115 | fun_body :: Inst 116 | } 117 | deriving (Eq) 118 | 119 | instance Outputable FunDec where 120 | ppr f = hang (text "function" <+> text (fun_name f)) 2 (ppr $ fun_body f) 121 | 122 | data Env = Env 123 | defaultEnv = Env 124 | 125 | type P a = StateT Env ChocoM a 126 | 127 | copyInst :: InstDesc -> M.Inst -> Inst -> Inst 128 | copyInst d i n = Inst { 129 | idesc = d, 130 | next = n, 131 | args = M.args i, 132 | result = M.result i, 133 | live = M.live i 134 | } 135 | 136 | addBranch :: Label -> Inst -> P Inst 137 | addBranch lbl n = 138 | if lbl >= 0 139 | then do 140 | n1 <- discardDeadCode n 141 | case idesc n1 of 142 | Llabel lbl1 | lbl1 == lbl -> 143 | return n1 144 | 145 | _ -> 146 | return $ consSimpleInst (Lbranch lbl) n1 147 | else 148 | discardDeadCode n 149 | 150 | discardDeadCode :: Inst -> P Inst 151 | discardDeadCode n = case idesc n of 152 | Lend -> return n 153 | Llabel _ -> return n 154 | _ -> discardDeadCode (next n) 155 | 156 | linear :: M.Inst -> Inst -> P Inst 157 | linear inst last = case M.idesc inst of 158 | M.Iend -> return last 159 | 160 | M.Iop M.Itailcall_ind -> 161 | discardDeadCode last >>= 162 | return . copyInst (Lop M.Itailcall_ind) inst 163 | 164 | M.Iop (M.Itailcall_imm s) -> 165 | discardDeadCode last >>= 166 | return . copyInst (Lop (M.Itailcall_imm s)) inst 167 | 168 | M.Iop op 169 | | op `elem` [M.Imove, M.Ireload, M.Ispill] && 170 | loc (M.args inst!!0) == loc (M.result inst!!0) -> 171 | linear (M.next inst) last 172 | 173 | M.Iop op -> 174 | linear (M.next inst) last >>= 175 | return . copyInst (Lop op) inst 176 | 177 | M.Ireturn -> 178 | discardDeadCode last >>= 179 | return . copyInst Lreturn inst 180 | 181 | M.Icond test ifso ifnot -> do 182 | n1 <- linear (M.next inst) last 183 | case (M.idesc ifso, M.idesc ifnot, idesc n1) of 184 | (M.Iend, _, Lbranch lbl) -> 185 | return . copyInst (Lcondbranch test lbl) inst 186 | =<< linear ifnot n1 187 | 188 | (_, M.Iend, Lbranch lbl) -> 189 | return . copyInst (Lcondbranch (M.invertTest test) lbl) inst 190 | =<< linear ifso n1 191 | 192 | (M.Iend, _, _) -> do 193 | (lbl_end, n2) <- getLabel n1 194 | return . copyInst (Lcondbranch test lbl_end) inst 195 | =<< linear ifnot n2 196 | 197 | (_, M.Iend, _) -> do 198 | (lbl_end, n2) <- getLabel n1 199 | return . copyInst (Lcondbranch (M.invertTest test) lbl_end) inst 200 | =<< linear ifso n2 201 | 202 | {- Should attempt branch prediction here -} 203 | (_, _, _) -> do 204 | (lbl_end, n2) <- getLabel n1 205 | (lbl_else, nelse) <- getLabel 206 | =<< linear ifnot n2 207 | 208 | return . copyInst (Lcondbranch (M.invertTest test) lbl_else) inst 209 | =<< linear ifso =<< addBranch lbl_end nelse 210 | 211 | 212 | M.Iloop body -> do 213 | lbl_head <- newLabel 214 | n1 <- linear (M.next inst) last 215 | n2 <- linear body (consSimpleInst (Lbranch lbl_head) n1) 216 | return $ consSimpleInst (Llabel lbl_head) n2 217 | 218 | fundecl fun = do 219 | fun_body <- evalStateT (linear (M.fun_body fun) endInst) 220 | defaultEnv 221 | return FunDec { 222 | fun_name = M.fun_name fun, 223 | fun_body = fun_body 224 | } 225 | -------------------------------------------------------------------------------- /src/Linearize_back.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Linearize ( 7 | Label, Inst(..), InstDesc(..), 8 | consInst, consNop, endInst, 9 | newLabel, 10 | hasFallthrough, 11 | FunDec(..), 12 | linearizeFunDec 13 | ) where 14 | 15 | import Id 16 | import Reg 17 | import qualified Mach as M 18 | import qualified CmmSyn as Cmm 19 | import qualified Data.Set as S 20 | import Panic 21 | 22 | import Control.Applicative 23 | import Control.Monad.State 24 | 25 | type Label = Int 26 | 27 | data Inst = Inst { 28 | idesc :: InstDesc, 29 | result :: [Reg], 30 | args :: [Reg], 31 | live :: S.Set Reg, 32 | next :: Inst 33 | } 34 | deriving (Eq) 35 | 36 | {- for test -} 37 | instance Show Inst where 38 | show Inst{idesc = Lend} = "" 39 | show (Inst i r a _ n) = 40 | show i ++ " "++ show r ++ " "++ show a ++ "\n" ++ show n 41 | 42 | 43 | data InstDesc 44 | = Lend 45 | | Lop M.Operation 46 | | Lnop 47 | | Lreturn 48 | | Llabel Label 49 | | Lbranch Label 50 | | Lcondbranch M.Test Label 51 | deriving (Eq, Show) 52 | 53 | labelCounter = genIdSource 99 54 | newLabel _ = newId labelCounter 55 | 56 | getLabel inst = case idesc inst of 57 | Lbranch lbl -> (lbl, inst) 58 | Llabel lbl -> (lbl, inst) 59 | Lend -> (-1, inst) 60 | _ -> let lbl = newLabel() in (lbl, consSimpleInst (Llabel lbl) inst) 61 | 62 | hasFallthrough inst 63 | = case inst of 64 | Lreturn -> False 65 | Lbranch _ -> False 66 | Lop M.Itailcall_ind -> False 67 | Lop (M.Itailcall_imm _) -> False 68 | _ -> True 69 | 70 | endInst = Inst { 71 | idesc = Lend, 72 | result = [], 73 | args = [], 74 | live = S.empty, 75 | next = endInst 76 | } 77 | 78 | consNop n = Inst { 79 | idesc = Lnop, 80 | result = [], 81 | args = [], 82 | live = S.empty, 83 | next = n 84 | } 85 | 86 | consInst d r a n = Inst { 87 | idesc = d, 88 | result = r, 89 | args = a, 90 | live = S.empty, 91 | next = n 92 | } 93 | 94 | consSimpleInst d n = Inst { 95 | idesc = d, 96 | result = [], 97 | args = [], 98 | live = S.empty, 99 | next = n 100 | } 101 | 102 | data FunDec = FunDec { 103 | fun_name :: String, 104 | fun_body :: Inst, 105 | fun_fast :: Bool 106 | } 107 | deriving (Eq, Show) 108 | 109 | data LinearEnv = LinearEnv { 110 | } 111 | 112 | defaultLinearEnv = LinearEnv {} 113 | 114 | type Linearizer a = State LinearEnv a 115 | 116 | copyInst :: InstDesc -> M.Inst -> Inst -> Inst 117 | copyInst d i n = Inst { 118 | idesc = d, 119 | next = n, 120 | args = M.args i, 121 | result = M.result i, 122 | live = M.live i 123 | } 124 | 125 | addBranch :: Label -> Inst -> Linearizer Inst 126 | addBranch lbl n = 127 | if lbl >= 0 128 | then do 129 | n1 <- discardDeadCode n 130 | case idesc n1 of 131 | Llabel lbl1 | lbl1 == lbl -> 132 | return n1 133 | 134 | _ -> 135 | return $ consSimpleInst (Lbranch lbl) n1 136 | else 137 | discardDeadCode n 138 | 139 | discardDeadCode :: Inst -> Linearizer Inst 140 | discardDeadCode n = case idesc n of 141 | Lend -> return n 142 | Llabel _ -> return n 143 | _ -> discardDeadCode (next n) 144 | 145 | linear :: M.Inst -> Inst -> Linearizer Inst 146 | linear inst last = case M.idesc inst of 147 | M.Iend -> return last 148 | 149 | M.Iop M.Itailcall_ind -> 150 | copyInst (Lop M.Itailcall_ind) inst <$> discardDeadCode last 151 | 152 | M.Iop (M.Itailcall_imm s) -> 153 | copyInst (Lop (M.Itailcall_imm s)) inst <$> discardDeadCode last 154 | 155 | M.Iop op -> 156 | copyInst (Lop op) inst <$> linear (M.next inst) last 157 | 158 | M.Ireturn -> 159 | copyInst Lreturn inst <$> discardDeadCode last 160 | 161 | M.Icond test ifso ifnot -> do 162 | n1 <- linear (M.next inst) last 163 | case (M.idesc ifso, M.idesc ifnot, idesc n1) of 164 | {- Should attempt branch prediction here -} 165 | (_, _, _) -> do 166 | let (lbl_end, n2) = getLabel n1 167 | (lbl_else, nelse) <- getLabel <$> linear ifnot n2 168 | copyInst (Lcondbranch (M.invertTest test) lbl_else) 169 | inst <$> (linear ifso =<< addBranch lbl_end nelse) 170 | 171 | M.Iloop body -> do 172 | let lbl_head = newLabel() 173 | n1 <- linear (M.next inst) last 174 | n2 <- linear body (consSimpleInst (Lbranch lbl_head) n1) 175 | return $ consSimpleInst (Llabel lbl_head) n2 176 | 177 | runLinearizer linearizer env = evalState linearizer env 178 | 179 | linearizeFunDec fun = FunDec { 180 | fun_name = M.fun_name fun, 181 | fun_body = runLinearizer 182 | (linear (M.fun_body fun) endInst) 183 | defaultLinearEnv, 184 | fun_fast = M.fun_fast fun 185 | } 186 | -------------------------------------------------------------------------------- /src/Liveness.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Liveness (fundecl) where 7 | 8 | {- liveness analysis -} 9 | 10 | import Choco 11 | import Mach 12 | import Outputable 13 | import Panic 14 | import Proc 15 | import Reg 16 | 17 | import Control.Monad.State 18 | import qualified Data.Set as S 19 | 20 | isNormal r = case loc r of 21 | Register r -> normalRegFirst <= r && r < normalRegEnd 22 | _ -> True 23 | 24 | normalArgs i = filter isNormal (args i) 25 | 26 | liveness i@Inst{ idesc = Iend } finally 27 | = (i{ live = finally }, finally) 28 | 29 | liveness i@Inst{ idesc = Ireturn } finally 30 | = (i, S.fromList (normalArgs i)) 31 | 32 | liveness i@Inst{ idesc = Iop Itailcall_ind } finally 33 | = (i, S.fromList (normalArgs i)) 34 | 35 | liveness i@Inst{ idesc = Iop (Itailcall_imm _) } finally 36 | = (i, S.fromList (normalArgs i)) 37 | 38 | liveness i@Inst{ idesc = Icond test ifso ifnot } finally 39 | = let 40 | (next', at_join) = liveness (next i) finally 41 | (ifso', at_fork1) = liveness ifso at_join 42 | (ifnot', at_fork2) = liveness ifnot at_join 43 | at_fork = S.union at_fork1 at_fork2 44 | in ( 45 | i{ idesc = Icond test ifso' ifnot', live = at_fork, next = next' }, 46 | S.union at_fork (S.fromList (normalArgs i)) 47 | ) 48 | 49 | liveness i@Inst{ idesc = Iloop body } finally 50 | = let 51 | (body', at_top) = walk body S.empty 52 | in ( 53 | i{ idesc = Iloop body', live = at_top }, 54 | at_top 55 | ) 56 | where 57 | walk body set = 58 | let (body', set') = liveness body set 59 | newset = S.union set set' 60 | in if newset == set 61 | then (body', newset) 62 | else walk body' newset 63 | 64 | liveness i finally 65 | = let (next', set) = liveness (next i) finally 66 | across = set S.\\ (S.fromList $ result i) 67 | in (i{ live = across, next = next' }, 68 | S.union across (S.fromList $ normalArgs i)) 69 | 70 | 71 | fundecl fun = do 72 | let (body', initially_live) = liveness (fun_body fun) S.empty 73 | {- Sanity check: only function parameters can be live at entrypoint -} 74 | wrong_live = initially_live S.\\ (S.fromList (fun_args fun)) 75 | if not (S.null wrong_live) 76 | then do 77 | simpleError $ text "wrong live variables:" <+> hsep (map ppr (S.toList wrong_live)) 78 | else return fun{ fun_body = body' } 79 | -------------------------------------------------------------------------------- /src/LocalCSE.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module LocalCSE where 7 | 8 | import Choco 9 | import Mach 10 | import Reg 11 | 12 | import Control.Monad.State 13 | import qualified Data.Map as M 14 | 15 | {- Common Subexpression Elimination -} 16 | 17 | type Index = Int 18 | 19 | data Node 20 | = Node { 21 | operation :: Operation, 22 | operands :: [Index] 23 | } 24 | | Leaf Index 25 | deriving (Show, Eq, Ord) 26 | 27 | type P a = StateT Env ChocoM a 28 | 29 | data Env = Env { 30 | vntable :: M.Map Reg Index, 31 | adaq :: M.Map Node Index 32 | } 33 | 34 | initEnv = Env { 35 | vntable = M.empty, 36 | adaq = M.empty 37 | } 38 | 39 | reset = put initEnv 40 | 41 | cse :: Inst -> P Inst 42 | cse i = case idesc i of 43 | Iend -> return i 44 | Ireturn -> return i 45 | 46 | Iop Icall_ind -> do 47 | reset 48 | next' <- cse (next i) 49 | return i{ next = next' } 50 | 51 | Iop (Icall_imm s) -> do 52 | reset 53 | next' <- cse (next i) 54 | return i{ next = next' } 55 | 56 | Iop Itailcall_ind -> do 57 | reset 58 | next' <- cse (next i) 59 | return i{ next = next' } 60 | 61 | Iop (Itailcall_imm s) -> do 62 | reset 63 | next' <- cse (next i) 64 | return i{ next = next' } 65 | 66 | Iop Imove 67 | -> do 68 | regNo (args i!!0) >>= setRegNo (result i!!0) 69 | next' <- cse (next i) 70 | return i{ next = next' } 71 | 72 | Iop (Iintop op) -> cseExp i 73 | Iop (Iintop_imm op n) -> cseExp i 74 | Iop op | op `elem` [Ifabs, Ifneg, Isqrt, Ifinv, Ifadd, Ifsub, Ifmul, Iftoi, Iitof] 75 | -> cseExp i 76 | Iop (Ihsr _) -> cseExp i 77 | 78 | Iop _ -> do 79 | next' <- cse (next i) 80 | return i{ next = next' } 81 | 82 | Icond tst i1 i2 -> do 83 | reset 84 | i1' <- cse i1 85 | reset 86 | i2' <- cse i2 87 | reset 88 | next' <- cse (next i) 89 | return i{ idesc = Icond tst i1' i2', next = next' } 90 | 91 | cseExp i@Inst{ idesc = Iop op } = do 92 | r <- lookupInst op (args i) 93 | case r of 94 | Just idx -> do 95 | table <- gets vntable 96 | case lookup idx (map (\(a,b) -> (b, a)) (M.toList table)) of 97 | Just r -> do 98 | next' <- cse (next i) 99 | return i{ 100 | idesc = Iop Imove, 101 | args = [r], 102 | next = next' 103 | } 104 | 105 | Nothing -> do 106 | next' <- cse (next i) 107 | return i{ next = next' } 108 | 109 | Nothing -> do 110 | idx <- lift$newUniq 111 | valno <- mapM regNo (args i) 112 | modify $ \e -> e{ 113 | adaq = M.insert Node{ operation = op, operands = valno } idx (adaq e) 114 | } 115 | setRegNo (result i!!0) idx 116 | next' <- cse(next i) 117 | return i{ next = next' } 118 | 119 | lookupInst op args = do 120 | operands <- mapM regNo args 121 | table <- gets adaq 122 | return $ M.lookup Node{ operation = op, operands = operands } table 123 | 124 | regNo :: Reg -> P Index 125 | regNo r = do 126 | tab <- gets vntable 127 | case M.lookup r tab of 128 | Just n -> return n 129 | Nothing -> do 130 | n <- lift$newUniq 131 | modify $ \e -> e{ vntable = M.insert r n tab } 132 | return n 133 | 134 | setRegNo :: Reg -> Index -> P () 135 | setRegNo r i = modify $ \e -> e{ vntable = M.insert r i (vntable e) } 136 | 137 | 138 | {- Peephole -} 139 | peephole i@Inst{ idesc = Iend } = i 140 | peephole i@Inst{ 141 | idesc = Iop (Ihsr _), 142 | next = Inst{ idesc = Iop Imove } 143 | } 144 | | result i == args (next i) 145 | = i{ result = result (next i), next = peephole (next (next i)) } 146 | peephole i@Inst{ idesc = Icond test ifso ifnot } 147 | = i{ idesc = Icond test (peephole ifso) (peephole ifnot), 148 | next = peephole (next i) } 149 | peephole i = i{ next = peephole (next i) } 150 | 151 | fundecl f = do 152 | body' <- evalStateT (cse (fun_body f)) initEnv 153 | return f{ fun_body = {- peephole -} body' } 154 | -------------------------------------------------------------------------------- /src/Log.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Log ( 7 | CLog(..), 8 | CLogs 9 | ) where 10 | 11 | import Data.Sequence 12 | import Text.PrettyPrint.HughesPJ 13 | 14 | data CLog 15 | = LargeLog { 16 | title :: String, 17 | body :: Doc 18 | } 19 | | SmallLog Doc 20 | | DebugLog String 21 | 22 | type CLogs = Seq CLog 23 | -------------------------------------------------------------------------------- /src/Mach.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Mach ( 7 | IntOperation(..), Test(..), 8 | Operation(..), 9 | Inst(..), InstDesc(..), 10 | instLength, 11 | invertTest, 12 | emptyInst, endInst, 13 | FunDec(..), 14 | consInst, consInstLive, 15 | instIter, 16 | pprOp, pprTest, 17 | destroyedRegisters 18 | ) where 19 | 20 | import Arch 21 | import Choco 22 | import Reg 23 | import Outputable 24 | import qualified CmmSyn as Cmm 25 | import qualified Data.Set as S 26 | 27 | import Control.Monad.State 28 | import qualified Data.Map as M 29 | 30 | {- representation of machine code -} 31 | 32 | data IntOperation 33 | = Iadd | Isub | Imul 34 | | Isra | Isll 35 | deriving (Eq, Ord, Show) 36 | 37 | instance Outputable IntOperation where 38 | ppr Iadd = char '+' 39 | ppr Isub = char '-' 40 | ppr Imul = char '*' 41 | ppr Isra = char '>' 42 | ppr Isll = char '<' 43 | 44 | data Test 45 | = Itruetest 46 | | Ifalsetest 47 | | Iinttest Cmm.Comp 48 | | Iinttest_imm Cmm.Comp Int 49 | | Ifloattest Cmm.Comp Bool 50 | deriving (Eq, Show) 51 | 52 | invertTest Itruetest = Ifalsetest 53 | invertTest Ifalsetest = Itruetest 54 | invertTest (Iinttest cmp) = Iinttest (Cmm.negateComp cmp) 55 | invertTest (Iinttest_imm cmp i) = Iinttest_imm (Cmm.negateComp cmp) i 56 | invertTest (Ifloattest cmp neg) = Ifloattest cmp (not neg) 57 | 58 | data Operation 59 | = Imove 60 | | Ispill 61 | | Ireload 62 | | Iconst_int Int 63 | | Iconst_float Float 64 | | Iconst_symbol String 65 | | Icall_ind 66 | | Icall_imm String 67 | | Itailcall_ind 68 | | Itailcall_imm String 69 | | Istackoffset Int 70 | | Iload Arch.AddressingMode 71 | | Istore Arch.AddressingMode 72 | | Ialloc Int 73 | | Iintop IntOperation 74 | | Iintop_imm IntOperation Int 75 | | Ifabs | Ifneg | Isqrt | Ifinv 76 | | Ifadd | Ifsub | Ifmul | Iftoi | Iitof 77 | | Iput | Iget 78 | | Ihsw Int | Ihsr Int 79 | deriving (Eq, Ord, Show) 80 | 81 | pprOp op res args = case op of 82 | Imove -> move (ppr (res!!0)) (ppr (args!!0)) 83 | Ispill -> move (ppr (res!!0)) (ppr (args!!0)) <+> text "(spill)" 84 | Ireload -> move (ppr (res!!0)) (ppr (args!!0)) <+> text "(reload)" 85 | Iconst_int n -> move (ppr (res!!0)) (int n) 86 | Iconst_float f -> move (ppr (res!!0)) (float f) 87 | Iconst_symbol s -> move (ppr (res!!0)) (text s) 88 | Icall_ind -> text "call" <+> hsep (map ppr args) 89 | Icall_imm s -> text "call" <+> text s <+> hsep (map ppr args) 90 | Itailcall_ind -> text "tailcall" <+> hsep (map ppr args) 91 | Itailcall_imm s -> text "tailcall" <+> text s <+> hsep (map ppr args) 92 | Istackoffset s 93 | | s > 0 -> text "%sp +=" <+> int s 94 | | s < 0 -> text "%sp -=" <+> int (-s) 95 | Iload addr -> ppr (res!!0) <+> text ":=" <+> memloc2 addr args 96 | Istore addr -> memloc addr args <+> text ":=" <+> ppr (args!!0) 97 | Ialloc n -> ppr (res!!0) <+> text ":= alloc" <+> int n 98 | Iintop op -> ppr (res!!0) <+> text ":=" <+> ppr (args!!0) <+> ppr op <+> ppr (args!!1) 99 | Iintop_imm op n -> ppr (res!!0) <+> text ":=" <+> ppr (args!!0) <+> ppr op <+> int n 100 | Ifabs -> ppr1 "fabs" 101 | Ifneg -> ppr1 "fneg" 102 | Isqrt -> ppr1 "fsqrt" 103 | Ifinv -> ppr1 "finv" 104 | Ifadd -> ppr2 "+." 105 | Ifsub -> ppr2 "-." 106 | Ifmul -> ppr2 "*." 107 | Iftoi -> ppr1 "ftoi" 108 | Iitof -> ppr1 "itof" 109 | Iput -> text "put" <+> ppr (args!!0) 110 | Iget -> ppr (res!!0) <+> text "<- get" 111 | Ihsw n -> text "hsw" <> int n <+> ppr (args!!0) 112 | Ihsr n -> ppr (res!!0) <+> text "hsr" <> int n 113 | where 114 | memloc (Ibased lbl offs) _ 115 | | offs >= 0 = brackets(text lbl <+> char '+' <+> int offs) 116 | | offs < 0 = brackets(text lbl <+> char '-' <+> int (-offs)) 117 | memloc (Iindexed idx) r 118 | | idx >= 0 = brackets(ppr (r!!1) <+> char '+' <+> int idx) 119 | | idx < 0 = brackets(ppr (r!!1) <+> char '-' <+> int (-idx)) 120 | 121 | memloc2 (Ibased lbl offs) _ 122 | | offs >= 0 = brackets(text lbl <+> char '+' <+> int offs) 123 | | offs < 0 = brackets(text lbl <+> char '-' <+> int (-offs)) 124 | memloc2 (Iindexed idx) r 125 | | idx >= 0 = brackets(ppr (r!!0) <+> char '+' <+> int idx) 126 | | idx < 0 = brackets(ppr (r!!0) <+> char '-' <+> int (-idx)) 127 | 128 | move a b = a <+> text ":=" <+> b 129 | ppr1 op = move (ppr (res!!0)) (text op <+> ppr (args!!0)) 130 | ppr2 op = move (ppr (res!!0)) (ppr (args!!0) <+> 131 | text op <+> ppr (args!!1)) 132 | 133 | pprTest test args = case test of 134 | Itruetest -> ppr (args!!0) <+> text "== true" 135 | Ifalsetest -> ppr (args!!0) <+> text "== false" 136 | Iinttest cmp -> ppr (args!!0) <+> ppr cmp <+> ppr (args!!1) 137 | Iinttest_imm cmp n -> ppr (args!!0) <+> ppr cmp <+> int n 138 | Ifloattest c True -> ppr (args!!1) <+> ppr c <+> ppr (args!!0) 139 | Ifloattest c False -> ppr (args!!0) <+> ppr c <+> ppr (args!!1) 140 | 141 | data Inst = Inst { 142 | idesc :: InstDesc, 143 | result :: [Reg], 144 | args :: [Reg], 145 | live :: S.Set Reg, 146 | 147 | next :: Inst 148 | } 149 | 150 | instLength :: Inst -> Int 151 | instLength i = case idesc i of 152 | Iend -> 0 153 | Ireturn -> 1 154 | Iop Itailcall_ind -> 1 155 | Iop (Itailcall_imm _) -> 1 156 | Icond _ i1 i2 -> instLength i1 + instLength i2 + 1 157 | _ -> 1 + instLength (next i) 158 | 159 | instance Eq Inst where 160 | Inst{ idesc = Iend } == Inst{ idesc = Iend } = True 161 | Inst{ idesc = Iend } == _ = False 162 | _ == Inst{ idesc = Iend } = False 163 | i1 == i2 = idesc i1 == idesc i2 && result i1 == result i2 && 164 | args i1 == args i2 && live i1 == live i2 && 165 | next i1 == next i2 166 | 167 | instance Outputable Inst where 168 | ppr Inst{ idesc = Iend } = empty 169 | ppr i@Inst{ idesc = Icond test ifso ifnot } 170 | = (hang (text "if" <+> pprTest test (args i)) 2 (vcat 171 | [hang (text "then") 2 (ppr ifso), 172 | hang (text "else") 2 (ppr ifnot)] 173 | )) $$ ppr (next i) 174 | ppr i@Inst{ idesc = Iop op } 175 | = pprOp op (result i) (args i) $$ ppr (next i) 176 | ppr i@Inst{ idesc = Ireturn } 177 | = text "return" $$ ppr (next i) 178 | 179 | instance Show Inst where 180 | show = show.ppr 181 | data InstDesc 182 | = Iend 183 | | Iop Operation 184 | | Ireturn 185 | | Icond Test Inst Inst 186 | | Iloop Inst 187 | deriving (Eq) 188 | 189 | data FunDec = FunDec { 190 | fun_name :: String, 191 | fun_args :: [Reg], 192 | fun_body :: Inst 193 | } 194 | deriving (Eq) 195 | 196 | instance Outputable FunDec where 197 | ppr f = hang (text "function" <+> text (fun_name f) <+> parens (hsep $ map ppr (fun_args f))) 2 (ppr (fun_body f)) 198 | 199 | emptyInst = Inst { 200 | idesc = Iend, 201 | args = [], 202 | result = [], 203 | live = S.empty, 204 | 205 | next = emptyInst 206 | } 207 | 208 | endInst = emptyInst 209 | 210 | consInst d r a n = Inst { 211 | idesc = d, 212 | result = r, 213 | args = a, 214 | live = S.empty, 215 | next = n 216 | } 217 | 218 | consInstLive d r a l n = Inst { 219 | idesc = d, 220 | result = r, 221 | args = a, 222 | live = l, 223 | next = n 224 | } 225 | instIter m i = 226 | case (idesc i) of 227 | Iend -> return i 228 | _ -> do 229 | i' <- m i 230 | case (idesc i') of 231 | Iend -> return i' 232 | Ireturn -> return i' 233 | Iop Itailcall_ind -> return i' 234 | Iop (Itailcall_imm _) -> return i' 235 | Icond tst ifso ifnot -> do 236 | ifso' <- instIter m ifso 237 | ifnot' <- instIter m ifnot 238 | next' <- instIter m (next i') 239 | return i'{ 240 | idesc = Icond tst ifso' ifnot', 241 | next = next' 242 | } 243 | _ -> do 244 | next' <- instIter m (next i') 245 | return i'{ 246 | next = next' 247 | } 248 | 249 | 250 | destroyedRegisters :: FunDec -> ChocoM [Reg] 251 | destroyedRegisters f = do 252 | rs <- walk S.empty (fun_body f) >>= return . S.toList 253 | return rs 254 | where 255 | walk rs i = case idesc i of 256 | Iend -> return rs 257 | Ireturn -> return rs 258 | Icond _ i1 i2 259 | -> do 260 | rs1 <- walk rs i1 261 | rs2 <- walk rs i2 262 | return (rs1 `S.union` rs2) 263 | 264 | Iop Icall_ind -> return . S.fromList =<< gets phys_regs 265 | Iop (Icall_imm s) -> do 266 | table <- gets fun_reg_info 267 | case M.lookup s table of 268 | Just rs2 -> walk (rs `S.union` (S.fromList rs2)) (next i) 269 | Nothing -> do 270 | return . S.fromList =<< gets phys_regs 271 | 272 | Iop Itailcall_ind -> return rs 273 | Iop (Itailcall_imm _) -> return rs 274 | Iop _ -> walk (rs `S.union` (S.fromList (result i))) (next i) 275 | 276 | 277 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | ------------------------------------------------- 3 | -- Choco -- 4 | -- Chikadzume Oriented Compiler -- 5 | -- Copyright 2007-2008 by Basement fairy -- 6 | ------------------------------------------------- 7 | module Main (main) where 8 | 9 | import AsmGen 10 | import Choco 11 | import Closure 12 | import CmmGen 13 | import CmmSyn 14 | import Emit 15 | import Driver 16 | import LamGen 17 | import LamOpt 18 | import Libraries 19 | import Mach 20 | import Outputable 21 | import Panic 22 | import Parser 23 | import Typing 24 | 25 | import Control.Exception (catchDyn) 26 | import Control.Monad.Reader 27 | import System.Exit 28 | import System.Cmd 29 | 30 | main = errorHandler $ do 31 | flags <- getCFlags 32 | execChoco chocoMain flags 33 | 34 | errorHandler f = 35 | f 36 | `catchDyn` 37 | (\(exception :: ChocoException) 38 | -> do print exception 39 | exitWith (ExitFailure 1)) 40 | `catch` 41 | (\exception 42 | -> do print exception 43 | exitWith (ExitFailure 1)) 44 | 45 | 46 | chocoMain = do 47 | flags <- ask 48 | 49 | src <- runIO $ if (in_name flags) == "" 50 | then getContents 51 | else readFile (in_name flags) 52 | 53 | {- parse source file -} 54 | putLog (text "parsing ...") 55 | ast <- parseProgram src 56 | when (dump_parser flags) $ 57 | report "Abstract syntax" (ppr ast) 58 | 59 | {- type check -} 60 | putLog (text "checking types ...") 61 | tystmt <- typeCheck ast 62 | when (dump_typecheck flags) $ 63 | report "Type check" (ppr tystmt) 64 | 65 | {- expand polymorphic functions -} 66 | -- unpolystmt <- unpolyProgram tystmt 67 | -- when (dump_unpoly flags) $ 68 | -- report "Specified types of polumorphic functions" (ppr unpolystmt) 69 | 70 | {- translate to Lambda langugage -} 71 | putLog (text "translating to lambda language ...") 72 | lam <- translLambda tystmt 73 | 74 | {- append library function definitions -} 75 | -- lam <- addLib lam 76 | when (dump_lambda flags) $ 77 | report "Lambda language" (ppr lam) 78 | 79 | {- simplify -} 80 | putLog (text "optimizing lambda language ...") 81 | lam' <- optimizeLambda (opt_command flags) lam 82 | when (dump_simpl flags) $ 83 | report "Optimized Lambda" (ppr lam') 84 | 85 | {- closure conversion -} 86 | putLog (text "closure conversion ...") 87 | ulam <- closeLambda lam' 88 | when (dump_close flags) $ 89 | report "Closed Lambda language" (ppr ulam) 90 | 91 | {- translate to C-- language -} 92 | putLog (text "translating to C-- ...") 93 | (cmm, hsram, greg, itab, ftab) <- translCmm ulam 94 | when (dump_cmm flags) $ 95 | report "C-- code" (ppr cmm) 96 | 97 | {- translate to Virtual Machine code -} 98 | putLog (text "generating assembly code ...") 99 | 100 | let (fundecls, datas) = divide cmm 101 | code <- Emit.fundecls (hsram, greg, itab, ftab) datas 102 | =<< mapM (asmgen flags itab ftab) fundecls 103 | 104 | if out_name flags == "" 105 | then report "Assembly code" code 106 | else runIO $ writeFile (out_name flags) $ render code 107 | 108 | when (assembler flags /= "") $ do 109 | putLog (text "generateing binary code by " 110 | <+> text (assembler flags) <+> text "...") 111 | runIO $ system $ assembler flags ++ " " ++ out_name flags 112 | return () 113 | return () 114 | 115 | where 116 | divide [] = ([], []) 117 | divide (Cfunction f:rem) = let (fs, cs) = divide rem in (f:fs, cs) 118 | divide (Cdata c:rem) = let (fs, cs) = divide rem in (fs, c:cs) 119 | -------------------------------------------------------------------------------- /src/McSyn.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module McSyn ( 7 | LMcStmt, LMcPat, LMcExpr, 8 | McStmt(..), McPat(..), McExpr(..), PreOp(..), BinOp(..) 9 | ) where 10 | 11 | import Common 12 | import Const 13 | import SrcLoc 14 | import Panic 15 | import Primitive 16 | import Outputable 17 | import Var 18 | 19 | import Data.List 20 | 21 | {- abstract syntax of MinCaml -} 22 | 23 | type LMcStmt = Located McStmt 24 | type LMcPat = Located McPat 25 | type LMcExpr = Located McExpr 26 | 27 | data McStmt 28 | = McEvalS LMcExpr 29 | | McValueS (LMcPat, LMcExpr) 30 | deriving (Eq) 31 | 32 | data McExpr 33 | = McVarE Name 34 | | McLitE Const 35 | | McAppE LMcExpr [LMcExpr] 36 | | McPrefixE PreOp LMcExpr 37 | | McInfixE BinOp LMcExpr LMcExpr 38 | | McLetE RecFlag (LMcPat, LMcExpr) LMcExpr 39 | | McFunE [LMcPat] LMcExpr 40 | | McSeqE LMcExpr LMcExpr 41 | | McCondE LMcExpr LMcExpr LMcExpr 42 | | McTupleE [LMcExpr] 43 | deriving (Eq) 44 | 45 | 46 | data McPat 47 | = McAnyP 48 | | McVarP Name 49 | | McTupleP [LMcPat] 50 | deriving (Eq) 51 | 52 | instance Outputable McStmt where 53 | ppr = pprStmt 54 | instance Outputable McExpr where 55 | ppr = pprExpr 56 | instance Outputable McPat where 57 | ppr = pprPat 58 | 59 | pprStmt (McEvalS expr) = ppr expr 60 | pprStmt (McValueS (var, val)) 61 | = hang (text "let") 2 (ppr var <+> char '=' <+> ppr val) 62 | 63 | pprExpr (McVarE id) = ppr id 64 | pprExpr (McLitE c) = ppr c 65 | pprExpr (McAppE f args) 66 | = hang (ppr f) 2 (sep (map pprParendExpr args)) 67 | pprExpr (McPrefixE op e) 68 | = ppr op <+> pprParendExpr e 69 | pprExpr (McInfixE op e1 e2) 70 | = pprParendExpr e1 <+> ppr op <+> pprParendExpr e2 71 | pprExpr (McLetE rec (var, val) expr) 72 | = let letstr = case rec of 73 | Rec -> text "let rec"; NonRec -> text "let" 74 | in sep [hang letstr 2 (ppr var <+> char '=' $$ ppr val), 75 | text "in", 76 | ppr expr] 77 | pprExpr (McFunE args body) 78 | = sep [hsep (text "fun" : intersperse (text "->") (map ppr args)) <+> text "->", 79 | nest 2 (ppr body) 80 | ] 81 | pprExpr (McSeqE e1 e2) 82 | = ppr e1 <> semi $$ ppr e2 83 | pprExpr (McCondE e1 e2 e3) 84 | = sep [hsep [text "if", nest 2 (ppr e1)], 85 | nest 2 (text "then" <+> ppr e2), 86 | nest 2 (text "else" <+> ppr e3) 87 | ] 88 | pprExpr (McTupleE elems) = parens.sep $ punctuate comma (map ppr elems) 89 | 90 | pprParendExpr expr 91 | = let pp = ppr expr 92 | in case unLoc expr of 93 | McVarE id -> ppr id 94 | McLitE c -> ppr c 95 | _ -> parens pp 96 | 97 | pprPat McAnyP = char '_' 98 | pprPat (McVarP id) = ppr id 99 | pprPat (McTupleP elems) = parens.sep $ punctuate comma (map ppr elems) 100 | -------------------------------------------------------------------------------- /src/MemAnal.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module MemAnal where 7 | 8 | import Choco 9 | import Const 10 | import LamSyn 11 | import Panic 12 | 13 | import Control.Monad.State 14 | import qualified Data.Map as M 15 | 16 | 17 | type ID = Int 18 | 19 | data MemStruct 20 | = Link ID 21 | | Word 22 | | Pointer 23 | | Array (Maybe Int) MemStruct 24 | | Tuple [MemStruct] 25 | 26 | data Env = Env { 27 | vtable :: M.Map Var (Maybe ID, ID), 28 | structs :: M.Map ID MemStruct, 29 | counter :: ID 30 | } 31 | 32 | type P a = StateT Env ChocoM a 33 | 34 | newID :: P ID 35 | newID = do 36 | c <- gets counter 37 | modify $ \e -> e{ counter = c + 1 } 38 | return c 39 | 40 | analyze :: Lambda -> P (Lambda, MemStruct) 41 | analyze lam = case lam of 42 | Llet str (v, PcreateArray _ _ [size, init]) cont 43 | -> case size of 44 | Llit (IntC n) -> do 45 | id <- newID 46 | (init', s1) <- analyze init 47 | modify $ \e -> e{ 48 | vtable = M.insert v (Nothing, id) (vtable e), 49 | structs = M.insert id (Array (Just n) s1) (structs e) 50 | } 51 | (cont', s2) <- analyze cont 52 | return (Llet str (v, 53 | -------------------------------------------------------------------------------- /src/Outputable.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Outputable ( 7 | Outputable(..), 8 | module Text.PrettyPrint.HughesPJ 9 | ) where 10 | 11 | import Control.Monad.Error 12 | import Text.PrettyPrint.HughesPJ 13 | 14 | instance Error Doc where 15 | noMsg = empty 16 | strMsg = text 17 | 18 | class Outputable a where 19 | ppr :: a -> Doc 20 | 21 | instance Outputable Doc where 22 | ppr = id 23 | 24 | instance Outputable Bool where 25 | ppr True = text "True" 26 | ppr False = text "False" 27 | 28 | instance Outputable Int where 29 | ppr n = int n 30 | 31 | instance Outputable () where 32 | ppr _ = text "()" 33 | 34 | instance (Outputable a) => Outputable [a] where 35 | ppr xs = brackets (fsep (punctuate comma (map ppr xs))) 36 | 37 | instance (Outputable a) => Outputable (Maybe a) where 38 | ppr Nothing = text "Nothing" 39 | ppr (Just x) = text "Just" <+> ppr x 40 | 41 | instance (Outputable a, Outputable b) => Outputable (a, b) where 42 | ppr (x, y) = parens (sep [ppr x <> comma, ppr y]) 43 | 44 | instance (Outputable a, Outputable b, Outputable c) 45 | => Outputable (a, b, c) where 46 | ppr (x, y, z) = parens (sep [ppr x <> comma, ppr y <> comma, ppr z]) 47 | -------------------------------------------------------------------------------- /src/Panic.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fglasgow-exts #-} 2 | ------------------------------------------------- 3 | -- Choco -- 4 | -- Chikadzume Oriented Compiler -- 5 | -- Copyright 2007-2008 by Basement fairy -- 6 | ------------------------------------------------- 7 | module Panic 8 | ( ChocoException(..) 9 | , panic 10 | ) where 11 | 12 | import Control.Exception 13 | import Data.Typeable 14 | import System.IO.Unsafe ( unsafePerformIO ) 15 | import System.Environment 16 | import System.Exit 17 | 18 | {- functions for error handling -} 19 | 20 | progName = unsafePerformIO (getProgName) 21 | {-# NOINLINE progName #-} 22 | 23 | data ChocoException 24 | = Panic String 25 | deriving (Eq, Typeable) 26 | 27 | instance Show ChocoException where 28 | show e = progName ++ ": " ++ showChocoException e 29 | 30 | showChocoException (Panic s) 31 | = "panic! (the 'impossible' happened): " ++ s 32 | 33 | panic :: String -> a 34 | panic x = throwDyn (Panic x) 35 | -------------------------------------------------------------------------------- /src/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# OPTIONS_GHC -w #-} 3 | ------------------------------------------------- 4 | -- Choco -- 5 | -- Chikadzume Oriented Compiler -- 6 | -- Copyright 2007-2008 by Basement fairy -- 7 | ------------------------------------------------- 8 | module Parser (parseProgram) where 9 | 10 | import Choco 11 | import Common 12 | import Const 13 | import Lexer 14 | import McSyn 15 | import Outputable 16 | import Primitive 17 | import SrcLoc 18 | import Var 19 | 20 | {- MinCaml parser -} 21 | } 22 | 23 | %token 24 | '_' { L _ Tunderscore } 25 | '-' { L _ Tminus } 26 | '+' { L _ Tplus } 27 | '*' { L _ Ttimes } 28 | '/' { L _ Tdiv } 29 | '-.' { L _ Tminusdot } 30 | '+.' { L _ Tplusdot } 31 | '*.' { L _ Tastdot } 32 | '/.' { L _ Tslashdot } 33 | '=' { L _ Tequal } 34 | '<>' { L _ Tnotequal } 35 | '<=' { L _ Tlessequal } 36 | '>=' { L _ Tgreaterequal } 37 | '<' { L _ Tless } 38 | '>' { L _ Tgreater } 39 | ',' { L _ Tcomma } 40 | '.' { L _ Tdot } 41 | ';' { L _ Tsemi } 42 | ';;' { L _ Tsemisemi } 43 | '(' { L _ Tlparen } 44 | ')' { L _ Trparen } 45 | '<-' { L _ Tlessminus } 46 | 47 | 'true' { L _ Ttrue } 48 | 'false' { L _ Tfalse } 49 | 'if' { L _ Tif } 50 | 'then' { L _ Tthen } 51 | 'else' { L _ Telse } 52 | 'let' { L _ Tlet } 53 | 'rec' { L _ Trec } 54 | 'in' { L _ Tin } 55 | 56 | ident { L _ (Tident _) } 57 | int { L _ (Tint _) } 58 | float { L _ (Tfloat _) } 59 | 60 | eof { L _ Teof } 61 | 62 | %monad { P } { >>= } { return } 63 | %lexer { lexer } { L _ Teof } 64 | %tokentype { Located Token } 65 | %name parseExpr seq_expr 66 | %name parse program 67 | 68 | %nonassoc 'in' 69 | %nonassoc ';;' 70 | %nonassoc ';' 71 | %nonassoc 'let' 72 | %nonassoc 'then' 73 | %nonassoc 'else' 74 | %nonassoc '<-' 75 | %nonassoc below_comma 76 | %left ',' 77 | %nonassoc below_equal 78 | %left '=' '<>' '<' '>' '<=' '>=' 79 | %left '+' '-' '+.' '-.' 80 | %left '*' '/' '*.' '/.' 81 | %nonassoc prec_unary_minus 82 | %nonassoc '.' 83 | %% 84 | 85 | program :: { [ LMcStmt ] } 86 | : stmt_tail { $1 } 87 | | seq_expr stmt_tail { sL (getLoc $1) (McEvalS $1) : $2 } 88 | 89 | stmt_tail :: { [ LMcStmt ] } 90 | : { [] } 91 | | ';;' { [] } 92 | | ';;' seq_expr stmt_tail { sL (getLoc $1) (McEvalS $2) : $3 } 93 | | ';;' stmt_item stmt_tail { $2 : $3 } 94 | | stmt_item stmt_tail { $1 : $2 } 95 | 96 | stmt_item :: { LMcStmt } 97 | : 'let' rec_flag let_binding 98 | { case unLoc $3 of 99 | (L _ McAnyP, exp) -> sL (comb2 $1 $>) (McEvalS exp) 100 | _ -> sL (comb2 $1 $>) (McValueS (unLoc $3)) 101 | } 102 | 103 | val_ident :: { Located Name } 104 | : ident 105 | { sL (getLoc $1) (getIDENT $ $1) } 106 | 107 | constant :: { Located Const } 108 | : int { sL (getLoc $1) (IntC (getINT $1)) } 109 | | float { sL (getLoc $1) (FloatC (getFLOAT $1)) } 110 | | '(' ')' { sL (comb2 $1 $>) UnitC } 111 | | 'true' { sL (getLoc $1) (BoolC True) } 112 | | 'false' { sL (getLoc $1) (BoolC False) } 113 | 114 | 115 | seq_expr :: { LMcExpr } 116 | : expr { $1 } 117 | | expr ';' { sL (comb2 $1 $>) (unLoc $1) } 118 | | expr ';' seq_expr { sL (comb2 $1 $>) (McSeqE $1 $3) } 119 | 120 | expr :: { LMcExpr } 121 | : simple_expr { $1 } 122 | | simple_expr simple_expr_list 123 | { sL (comb2 $1 $>) (McAppE $1 (reverse (unLoc $2))) } 124 | | 'let' rec_flag let_binding 'in' seq_expr 125 | { sL (comb2 $1 $>) (McLetE $2 (unLoc $3) $5) } 126 | | expr_comma_list 127 | { sL (getLoc $1) (McTupleE . reverse . unLoc $ $1) } 128 | | 'if' seq_expr 'then' expr 'else' expr 129 | { sL (comb2 $1 $>) (McCondE $2 $4 $6) } 130 | | '-' expr %prec prec_unary_minus 131 | { sL (comb2 $1 $>) (mkNeg $2) } 132 | | '-.' expr %prec prec_unary_minus 133 | { sL (comb2 $1 $>) (mkFNeg $2) } 134 | | expr '+' expr { sL (comb2 $1 $>) (McInfixE Add $1 $3) } 135 | | expr '-' expr { sL (comb2 $1 $>) (McInfixE Sub $1 $3) } 136 | | expr '*' expr { sL (comb2 $1 $>) (McInfixE Mul $1 $3) } 137 | | expr '/' expr { sL (comb2 $1 $>) (McInfixE Div $1 $3) } 138 | | expr '+.' expr { sL (comb2 $1 $>) (McInfixE FAdd $1 $3) } 139 | | expr '-.' expr { sL (comb2 $1 $>) (McInfixE FSub $1 $3) } 140 | | expr '*.' expr { sL (comb2 $1 $>) (McInfixE FMul $1 $3) } 141 | | expr '/.' expr { sL (comb2 $1 $>) (McInfixE FDiv $1 $3) } 142 | | expr '=' expr { sL (comb2 $1 $>) (McInfixE Eq $1 $3) } 143 | | expr '<>' expr { sL (comb2 $1 $>) (McInfixE Ne $1 $3) } 144 | | expr '<=' expr { sL (comb2 $1 $>) (McInfixE Le $1 $3) } 145 | | expr '>=' expr { sL (comb2 $1 $>) (McInfixE Ge $1 $3) } 146 | | expr '<' expr { sL (comb2 $1 $>) (McInfixE Lt $1 $3) } 147 | | expr '>' expr { sL (comb2 $1 $>) (McInfixE Gt $1 $3) } 148 | | simple_expr '.' '(' seq_expr ')' '<-' expr 149 | { sL (comb2 $1 $>) 150 | (McAppE (L noSrcLoc (McVarE $ mkName arraySetName)) [$1, $4, $7]) } 151 | 152 | expr_comma_list :: { Located [LMcExpr] } 153 | : expr_comma_list ',' expr { sL (comb2 $1 $>) ($3 : (unLoc $1)) } 154 | | expr ',' expr { sL (comb2 $1 $>) [$3, $1] } 155 | 156 | simple_expr :: { LMcExpr } 157 | : val_ident { sL (getLoc $1) (McVarE (unLoc $1)) } 158 | | constant { sL (getLoc $1) (McLitE (unLoc $1)) } 159 | | '(' seq_expr ')' { sL (comb2 $1 $>) (unLoc $2) } 160 | | simple_expr '.' '(' seq_expr ')' 161 | { sL (comb2 $1 $>) 162 | (McAppE (L noSrcLoc (McVarE $ mkName arrayGetName)) [$1, $4]) } 163 | 164 | simple_expr_list :: { Located [ LMcExpr ] } 165 | : simple_expr { sL (getLoc $1) [ $1 ] } 166 | | simple_expr_list simple_expr { sL (comb2 $1 $>) ($2 : (unLoc $1)) } 167 | 168 | rec_flag :: { RecFlag } 169 | : { NonRec } 170 | | 'rec' { Rec } 171 | 172 | 173 | let_binding :: { Located (LMcPat, LMcExpr) } 174 | : val_ident fun_binding { sL (comb2 $1 $>) (mkVarP $1, $2) } 175 | | pattern '=' seq_expr { sL (comb2 $1 $>) ($1, $3) } 176 | 177 | fun_binding :: { LMcExpr } 178 | : simple_pattern_list '=' seq_expr 179 | { sL (comb2 $1 $>) (McFunE (reverse (unLoc $1)) $3) } 180 | 181 | pattern :: { LMcPat } 182 | : simple_pattern { $1 } 183 | | pattern_comma_list %prec below_comma 184 | { sL (getLoc $1) (McTupleP (reverse (unLoc $1))) } 185 | 186 | simple_pattern :: { LMcPat } 187 | : val_ident %prec below_equal { mkVarP $1 } 188 | | '_' { sL (getLoc $1) McAnyP } 189 | | '(' pattern ')' { sL (comb2 $1 $>) (unLoc $2) } 190 | 191 | simple_pattern_list :: { Located [LMcPat] } 192 | : simple_pattern_list simple_pattern 193 | { sL (comb2 $1 $>) ($2 : (unLoc $1)) } 194 | | simple_pattern 195 | { sL (getLoc $1) [$1] } 196 | 197 | pattern_comma_list :: { Located [LMcPat] } 198 | : pattern_comma_list ',' pattern 199 | { sL (comb2 $1 $>) ($3 : unLoc $1) } 200 | | pattern ',' pattern 201 | { sL (comb2 $1 $>) [$3, $1] } 202 | 203 | { 204 | getIDENT (L _ (Tident x)) = x 205 | getINT (L _ (Tint x)) = x 206 | getFLOAT (L _ (Tfloat x)) = read x 207 | 208 | mkVarE (L loc name) = sL loc (McVarE name) 209 | mkVarP (L loc name) = sL loc (McVarP name) 210 | 211 | mkNeg (L _ (McLitE (IntC n))) = McLitE (IntC (-n)) 212 | mkNeg (L _ (McLitE (FloatC f))) = McLitE (FloatC (-f)) 213 | mkNeg e = McPrefixE Neg e 214 | 215 | mkFNeg (L _ (McLitE (FloatC f))) = McLitE (FloatC (-f)) 216 | mkFNeg e = McPrefixE FNeg e 217 | 218 | reLoc (L loc _) (L _ e) = sL loc e 219 | 220 | comb2 :: Located a -> Located b -> SrcLoc 221 | comb2 a b = combineSrcLoc (getLoc a) (getLoc b) 222 | 223 | 224 | happyError :: P a 225 | happyError = fail "parse error" 226 | 227 | {- external interface -} 228 | parseProgram :: String -> ChocoM [LMcStmt] 229 | parseProgram src = do 230 | case runP src parse of 231 | POk _ p -> return p 232 | PFailed loc msg -> 233 | compileError (text msg) loc 234 | } 235 | -------------------------------------------------------------------------------- /src/Primitive.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Primitive ( 7 | PreOp(..), BinOp(..), 8 | preopType, binopType, 9 | arrayConName, arraySetName, arrayGetName, 10 | primTable, extPrefix 11 | ) where 12 | 13 | import Const 14 | import LamSyn 15 | import qualified Outputable as O 16 | import Panic 17 | import Types 18 | import Var 19 | 20 | import qualified Data.Map as M 21 | import qualified Data.IntSet as S 22 | 23 | data PreOp = Neg | FNeg deriving (Eq, Show) 24 | data BinOp 25 | = Add | Sub | Mul | Div | FAdd | FSub | FMul | FDiv 26 | | Eq | Ne | Le | Ge | Lt | Gt 27 | deriving (Eq, Show, Ord) 28 | 29 | instance O.Outputable PreOp where 30 | ppr Neg = O.char '-' 31 | ppr FNeg = O.text "-." 32 | instance O.Outputable BinOp where 33 | ppr Add = O.char '+' 34 | ppr Sub = O.char '-' 35 | ppr Mul = O.char '*' 36 | ppr Div = O.char '/' 37 | ppr FAdd = O.text "+." 38 | ppr FSub = O.text "-." 39 | ppr FMul = O.text "*." 40 | ppr FDiv = O.text "/." 41 | ppr Eq = O.char '=' 42 | ppr Ne = O.text "<>" 43 | ppr Le = O.text "<=" 44 | ppr Ge = O.text ">=" 45 | ppr Lt = O.char '<' 46 | ppr Gt = O.char '>' 47 | 48 | preopType Neg = IntT 49 | preopType FNeg = FloatT 50 | 51 | binopType op 52 | | Add <= op && op <= Div = Just IntT 53 | | FAdd <= op && op <= FDiv = Just FloatT 54 | | otherwise = Nothing 55 | 56 | 57 | arraySetName = "set_array" 58 | arrayGetName = "get_array" 59 | arrayConName = "create_array" 60 | 61 | {- primitive functions -} 62 | extPrefix = "lib_" 63 | mkExtCall name b r = Pextcall (extPrefix ++ name) b r 64 | 65 | primTable :: (VarMap, LamMap) 66 | primTable = 67 | (\(vm, lm) -> (M.fromList vm, M.fromList lm)) $ 68 | unzip $ 69 | map (\(id,name,ty,fn) -> ((mkName name, (ty,id,True)), (name,fn))) $ 70 | [ 71 | (0, "not", 72 | toScheme $ bool --> bool, 73 | Lprim Pnot 74 | ), 75 | 76 | (1, "create_array", 77 | forall [a'] (int --> a' --> array a'), 78 | Lprim PcreateArray 79 | ), 80 | 81 | (2, "get_array", 82 | forall [a'] (array a' --> int --> a'), 83 | Lprim ParrayRef 84 | ), 85 | 86 | (3, "set_array", 87 | forall [a'] (array a' --> int --> a' --> unit), 88 | Lprim ParraySet 89 | ), 90 | 91 | (4, "int_of_float", 92 | toScheme $ float --> int, 93 | Lprim (mkExtCall "int_of_float" False True) 94 | -- genApp "int_of_float" 95 | ), 96 | 97 | (5, "float_of_int", 98 | toScheme $ int --> float, 99 | Lprim (mkExtCall "float_of_int" False True) 100 | -- genApp "float_of_int" 101 | ), 102 | 103 | (6, "print_byte", 104 | toScheme $ int --> unit, 105 | Lprim Pput 106 | ), 107 | 108 | (7, "print_char", 109 | toScheme $ int --> unit, 110 | Lprim Pput 111 | ), 112 | 113 | (8, "print_int", 114 | toScheme $ int --> unit, 115 | Lprim (mkExtCall "print_int" True False) 116 | ), 117 | 118 | (9, "read_int", 119 | toScheme $ unit --> int, 120 | Lprim (mkExtCall "read" True True) 121 | -- genApp "read_int" 122 | ), 123 | 124 | (10, "read_float", 125 | toScheme $ unit --> float, 126 | Lprim (mkExtCall "read" True True) 127 | -- genApp "read_float" 128 | ), 129 | 130 | (11, "sin", 131 | toScheme $ float --> float, 132 | Lprim (mkExtCall "sin" False True) 133 | ), 134 | (12, "cos", 135 | toScheme $ float --> float, 136 | Lprim (mkExtCall "cos" False True) 137 | ), 138 | (13, "atan", 139 | toScheme $ float --> float, 140 | Lprim (mkExtCall "atan" False True) 141 | ), 142 | 143 | (14, "sqrt", 144 | toScheme $ float --> float, 145 | Lprim Psqrt 146 | ), 147 | 148 | (15, "floor", 149 | toScheme $ float --> float, 150 | Lprim (mkExtCall "floor" False True) 151 | -- genApp "floor" 152 | ), 153 | 154 | (16, "fiszero", 155 | toScheme $ float --> bool, 156 | \[arg] -> Lprim (Pcompf Ceq) [arg, Llit (FloatC 0.0)] 157 | ), 158 | 159 | (17, "fispos", 160 | toScheme $ float --> bool, 161 | \[arg] -> Lprim (Pcompf Cgt) [arg, Llit (FloatC 0.0)] 162 | ), 163 | 164 | (18, "fisneg", 165 | toScheme $ float --> bool, 166 | \[arg] -> Lprim (Pcompf Clt) [arg, Llit (FloatC 0.0)] 167 | ), 168 | 169 | (19, "fless", 170 | toScheme $ float --> float --> bool, 171 | Lprim (Pcompf Clt) 172 | ), 173 | 174 | (20, "fabs", 175 | toScheme $ float --> float, 176 | Lprim Pabsf 177 | ), 178 | 179 | (30, "fneg", 180 | toScheme $ float --> float, 181 | Lprim Pnegf 182 | ), 183 | 184 | (40, "fhalf", 185 | toScheme $ float --> float, 186 | \[arg] -> Lprim Pdivf [arg, Llit (FloatC 2.0)] 187 | ), 188 | 189 | (41, "fsqr", 190 | toScheme $ float --> float, 191 | \[arg] -> Lprim Pmulf [arg, arg] 192 | ) 193 | ] 194 | 195 | genApp :: String -> [Lambda] -> Lambda 196 | genApp name args = 197 | let (ty, id, _) = (fst primTable) M.! (mkName name) 198 | TyScheme _ t = ty 199 | in Lapp (Lvar $ mkVar name id ty False) args (case t of 200 | UnitT -> False 201 | _ -> True 202 | ) 203 | 204 | {- utilities -} 205 | a' = TyVar 0 206 | unit = UnitT 207 | bool = BoolT 208 | int = IntT 209 | float = FloatT 210 | array x = ArrayT x 211 | 212 | forall ts ty 213 | = let ids = S.fromList $ map untag ts 214 | in TyScheme ids ty 215 | where 216 | untag (TyVar id) = id 217 | untag _ = panic "Primitive.forall" 218 | 219 | infixr 1 --> 220 | (-->) :: Type -> Type -> Type 221 | a --> FunT args ret = FunT (a:args) ret 222 | a --> b = FunT [a] b 223 | 224 | -------------------------------------------------------------------------------- /src/Primitive_NoCmmLib.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Primitive ( 7 | PreOp(..), BinOp(..), 8 | preopType, binopType, 9 | arrayConName, arraySetName, arrayGetName, 10 | primTable, extPrefix 11 | ) where 12 | 13 | import Const 14 | import LamSyn 15 | import qualified Outputable as O 16 | import Panic 17 | import Types 18 | import Var 19 | 20 | import qualified Data.Map as M 21 | import qualified Data.IntSet as S 22 | 23 | data PreOp = Neg | FNeg deriving (Eq, Show) 24 | data BinOp 25 | = Add | Sub | Mul | Div | FAdd | FSub | FMul | FDiv 26 | | Eq | Ne | Le | Ge | Lt | Gt 27 | deriving (Eq, Show, Ord) 28 | 29 | instance O.Outputable PreOp where 30 | ppr Neg = O.char '-' 31 | ppr FNeg = O.text "-." 32 | instance O.Outputable BinOp where 33 | ppr Add = O.char '+' 34 | ppr Sub = O.char '-' 35 | ppr Mul = O.char '*' 36 | ppr Div = O.char '/' 37 | ppr FAdd = O.text "+." 38 | ppr FSub = O.text "-." 39 | ppr FMul = O.text "*." 40 | ppr FDiv = O.text "/." 41 | ppr Eq = O.char '=' 42 | ppr Ne = O.text "<>" 43 | ppr Le = O.text "<=" 44 | ppr Ge = O.text ">=" 45 | ppr Lt = O.char '<' 46 | ppr Gt = O.char '>' 47 | 48 | preopType Neg = IntT 49 | preopType FNeg = FloatT 50 | 51 | binopType op 52 | | Add <= op && op <= Div = Just IntT 53 | | FAdd <= op && op <= FDiv = Just FloatT 54 | | otherwise = Nothing 55 | 56 | 57 | arraySetName = "set_array" 58 | arrayGetName = "get_array" 59 | arrayConName = "create_array" 60 | 61 | {- primitive functions -} 62 | extPrefix = "lib_" 63 | mkExtCall name b r = Pextcall (extPrefix ++ name) b r 64 | 65 | primTable :: (VarMap, LamMap) 66 | primTable = 67 | (\(vm, lm) -> (M.fromList vm, M.fromList lm)) $ 68 | unzip $ 69 | map (\(id,name,ty,fn) -> ((mkName name, (ty,id,True)), (name,fn))) $ 70 | [ 71 | (0, "not", 72 | toScheme $ bool --> bool, 73 | Lprim Pnot 74 | ), 75 | 76 | (1, "create_array", 77 | forall [a'] (int --> a' --> array a'), 78 | Lprim PcreateArray 79 | ), 80 | 81 | (2, "get_array", 82 | forall [a'] (array a' --> int --> a'), 83 | Lprim ParrayRef 84 | ), 85 | 86 | (3, "set_array", 87 | forall [a'] (array a' --> int --> a' --> unit), 88 | Lprim ParraySet 89 | ), 90 | 91 | (4, "int_of_float", 92 | toScheme $ float --> int, 93 | Lprim (mkExtCall "int_of_float" False True) 94 | ), 95 | 96 | (5, "float_of_int", 97 | toScheme $ int --> float, 98 | Lprim (mkExtCall "float_of_int" False True) 99 | ), 100 | 101 | (6, "print_byte", 102 | toScheme $ int --> unit, 103 | Lprim Pput 104 | ), 105 | 106 | (7, "print_char", 107 | toScheme $ int --> unit, 108 | Lprim Pput 109 | ), 110 | 111 | (8, "print_int", 112 | toScheme $ int --> unit, 113 | Lprim (mkExtCall "print_int" True False) 114 | ), 115 | 116 | (9, "read_int", 117 | toScheme $ unit --> int, 118 | Lprim (mkExtCall "read" True True) 119 | ), 120 | 121 | (10, "read_float", 122 | toScheme $ unit --> float, 123 | Lprim (mkExtCall "read" True True) 124 | ), 125 | 126 | (11, "sin", 127 | toScheme $ float --> float, 128 | Lprim (mkExtCall "sin" False True) 129 | ), 130 | (12, "cos", 131 | toScheme $ float --> float, 132 | Lprim (mkExtCall "cos" False True) 133 | ), 134 | (13, "atan", 135 | toScheme $ float --> float, 136 | Lprim (mkExtCall "atan" False True) 137 | ), 138 | 139 | (14, "sqrt", 140 | toScheme $ float --> float, 141 | Lprim Psqrt 142 | ), 143 | 144 | (15, "floor", 145 | toScheme $ float --> float, 146 | Lprim (mkExtCall "floor" False True) 147 | ), 148 | 149 | (16, "fiszero", 150 | toScheme $ float --> bool, 151 | \[arg] -> Lprim (Pcompf Ceq) [arg, Llit (FloatC 0.0)] 152 | ), 153 | 154 | (17, "fispos", 155 | toScheme $ float --> bool, 156 | \[arg] -> Lprim (Pcompf Cgt) [arg, Llit (FloatC 0.0)] 157 | ), 158 | 159 | (18, "fisneg", 160 | toScheme $ float --> bool, 161 | \[arg] -> Lprim (Pcompf Clt) [arg, Llit (FloatC 0.0)] 162 | ), 163 | 164 | (19, "fless", 165 | toScheme $ float --> float --> bool, 166 | Lprim (Pcompf Clt) 167 | ), 168 | 169 | (20, "fabs", 170 | toScheme $ float --> float, 171 | Lprim Pabsf 172 | ), 173 | 174 | (30, "fneg", 175 | toScheme $ float --> float, 176 | Lprim Pnegf 177 | ), 178 | 179 | (40, "fhalf", 180 | toScheme $ float --> float, 181 | \[arg] -> Lprim Pdivf [arg, Llit (FloatC 2.0)] 182 | ), 183 | 184 | (41, "fsqr", 185 | toScheme $ float --> float, 186 | \[arg] -> Lprim Pmulf [arg, arg] 187 | ) 188 | ] 189 | 190 | {- utilities -} 191 | a' = TyVar 0 192 | unit = UnitT 193 | bool = BoolT 194 | int = IntT 195 | float = FloatT 196 | array x = ArrayT x 197 | 198 | forall ts ty 199 | = let ids = S.fromList $ map untag ts 200 | in TyScheme ids ty 201 | where 202 | untag (TyVar id) = id 203 | untag _ = panic "Primitive.forall" 204 | 205 | infixr 1 --> 206 | (-->) :: Type -> Type -> Type 207 | a --> FunT args ret = FunT (a:args) ret 208 | a --> b = FunT [a] b 209 | 210 | -------------------------------------------------------------------------------- /src/Primitive_WithCmmLib.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Primitive ( 7 | PreOp(..), BinOp(..), 8 | preopType, binopType, 9 | arrayConName, arraySetName, arrayGetName, 10 | primTable, extPrefix 11 | ) where 12 | 13 | import Const 14 | import LamSyn 15 | import qualified Outputable as O 16 | import Panic 17 | import Types 18 | import Var 19 | 20 | import qualified Data.Map as M 21 | import qualified Data.IntSet as S 22 | 23 | data PreOp = Neg | FNeg deriving (Eq, Show) 24 | data BinOp 25 | = Add | Sub | Mul | Div | FAdd | FSub | FMul | FDiv 26 | | Eq | Ne | Le | Ge | Lt | Gt 27 | deriving (Eq, Show, Ord) 28 | 29 | instance O.Outputable PreOp where 30 | ppr Neg = O.char '-' 31 | ppr FNeg = O.text "-." 32 | instance O.Outputable BinOp where 33 | ppr Add = O.char '+' 34 | ppr Sub = O.char '-' 35 | ppr Mul = O.char '*' 36 | ppr Div = O.char '/' 37 | ppr FAdd = O.text "+." 38 | ppr FSub = O.text "-." 39 | ppr FMul = O.text "*." 40 | ppr FDiv = O.text "/." 41 | ppr Eq = O.char '=' 42 | ppr Ne = O.text "<>" 43 | ppr Le = O.text "<=" 44 | ppr Ge = O.text ">=" 45 | ppr Lt = O.char '<' 46 | ppr Gt = O.char '>' 47 | 48 | preopType Neg = IntT 49 | preopType FNeg = FloatT 50 | 51 | binopType op 52 | | Add <= op && op <= Div = Just IntT 53 | | FAdd <= op && op <= FDiv = Just FloatT 54 | | otherwise = Nothing 55 | 56 | 57 | arraySetName = "set_array" 58 | arrayGetName = "get_array" 59 | arrayConName = "create_array" 60 | 61 | {- primitive functions -} 62 | extPrefix = "lib_" 63 | mkExtCall name b r = Pextcall (extPrefix ++ name) b r 64 | 65 | -- fix function entries 66 | primTable :: (VarMap, LamMap) 67 | primTable = 68 | (\(vm, lm) -> (M.fromList vm, M.fromList lm)) $ 69 | unzip $ 70 | map (\(id,name,ty,fn) -> ((mkName name, (ty,id,True)), (name,fn))) $ 71 | [ 72 | (0, "not", 73 | toScheme $ bool --> bool, 74 | Lprim Pnot 75 | ), 76 | 77 | (1, "create_array", 78 | forall [a'] (int --> a' --> array a'), 79 | Lprim PcreateArray 80 | ), 81 | 82 | (2, "get_array", 83 | forall [a'] (array a' --> int --> a'), 84 | Lprim ParrayRef 85 | ), 86 | 87 | (3, "set_array", 88 | forall [a'] (array a' --> int --> a' --> unit), 89 | Lprim ParraySet 90 | ), 91 | 92 | (4, "int_of_float", 93 | toScheme $ float --> int, 94 | genApp "int_of_float" 95 | ), 96 | 97 | (5, "float_of_int", 98 | toScheme $ int --> float, 99 | genApp "float_of_int" 100 | ), 101 | 102 | (6, "print_byte", 103 | toScheme $ int --> unit, 104 | Lprim Pput 105 | ), 106 | 107 | (7, "print_char", 108 | toScheme $ int --> unit, 109 | Lprim Pput 110 | ), 111 | 112 | (8, "print_int", 113 | toScheme $ int --> unit, 114 | Lprim (mkExtCall "print_int" True False) 115 | ), 116 | 117 | (9, "read_int", 118 | toScheme $ unit --> int, 119 | genApp "read_int" 120 | ), 121 | 122 | (10, "read_float", 123 | toScheme $ unit --> float, 124 | genApp "read_float" 125 | ), 126 | 127 | (11, "sin", 128 | toScheme $ float --> float, 129 | genApp "sin" 130 | ), 131 | (12, "cos", 132 | toScheme $ float --> float, 133 | genApp "cos" 134 | ), 135 | (13, "atan", 136 | toScheme $ float --> float, 137 | genApp "atan" 138 | ), 139 | 140 | (14, "sqrt", 141 | toScheme $ float --> float, 142 | Lprim Psqrt 143 | ), 144 | 145 | (15, "floor", 146 | toScheme $ float --> float, 147 | genApp "floor" 148 | ), 149 | 150 | (16, "fiszero", 151 | toScheme $ float --> bool, 152 | \[arg] -> Lprim (Pcompf Ceq) [arg, Llit (FloatC 0.0)] 153 | ), 154 | 155 | (17, "fispos", 156 | toScheme $ float --> bool, 157 | \[arg] -> Lprim (Pcompf Cgt) [arg, Llit (FloatC 0.0)] 158 | ), 159 | 160 | (18, "fisneg", 161 | toScheme $ float --> bool, 162 | \[arg] -> Lprim (Pcompf Clt) [arg, Llit (FloatC 0.0)] 163 | ), 164 | 165 | (19, "fless", 166 | toScheme $ float --> float --> bool, 167 | Lprim (Pcompf Clt) 168 | ), 169 | 170 | (20, "fabs", 171 | toScheme $ float --> float, 172 | Lprim Pabsf 173 | ), 174 | 175 | (30, "fneg", 176 | toScheme $ float --> float, 177 | Lprim Pnegf 178 | ), 179 | 180 | (40, "fhalf", 181 | toScheme $ float --> float, 182 | \[arg] -> Lprim Pdivf [arg, Llit (FloatC 2.0)] 183 | ), 184 | 185 | (41, "fsqr", 186 | toScheme $ float --> float, 187 | \[arg] -> Lprim Pmulf [arg, arg] 188 | ) 189 | ] 190 | 191 | genApp :: String -> [Lambda] -> Lambda 192 | genApp name args = 193 | let (ty, id, _) = (fst primTable) M.! (mkName name) 194 | TyScheme _ t = ty 195 | in Lapp (Lvar $ mkVar name id ty False) args (case t of 196 | UnitT -> False 197 | _ -> True 198 | ) 199 | 200 | {- utilities -} 201 | a' = TyVar 0 202 | unit = UnitT 203 | bool = BoolT 204 | int = IntT 205 | float = FloatT 206 | array x = ArrayT x 207 | 208 | forall ts ty 209 | = let ids = S.fromList $ map untag ts 210 | in TyScheme ids ty 211 | where 212 | untag (TyVar id) = id 213 | untag _ = panic "Primitive.forall" 214 | 215 | infixr 1 --> 216 | (-->) :: Type -> Type -> Type 217 | a --> FunT args ret = FunT (a:args) ret 218 | a --> b = FunT [a] b 219 | 220 | -------------------------------------------------------------------------------- /src/Reg.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Reg ( 7 | Reg(..), RegInfo(..), Location(..), 8 | StackLocation(..), StaticLocation(..), 9 | emptyReg, emptyRegInfo 10 | ) where 11 | 12 | import CmmSyn 13 | import Outputable 14 | 15 | import Control.Monad.State 16 | import qualified Data.Map as M 17 | 18 | data Reg = Reg { 19 | name :: String, 20 | stamp :: Int, 21 | loc :: Location 22 | } 23 | deriving (Show) 24 | 25 | instance Eq Reg where 26 | Reg{ stamp = i1 } == Reg{ stamp = i2 } = i1 == i2 27 | 28 | instance Outputable Reg where 29 | ppr r = text (name r) <> char '#' <> int (stamp r) <> 30 | case loc r of 31 | Unknown -> empty 32 | Register n -> brackets(char 'r' <> int n) 33 | Stack s -> brackets(ppr s) 34 | 35 | data RegInfo = RegInfo { 36 | spill :: Bool, 37 | interf :: [Reg], 38 | prefer :: [(Reg, Int)], 39 | degree :: Int, 40 | spillCost :: Int, 41 | visited :: Bool, 42 | 43 | location :: Location -- for register allocation 44 | } 45 | deriving (Show) 46 | 47 | data Location 48 | = Unknown 49 | | Register Int 50 | | Stack StackLocation 51 | deriving (Eq, Show, Ord) 52 | 53 | data StackLocation 54 | = Local Int 55 | | Incoming Int 56 | | Outgoing Int 57 | deriving (Eq, Show, Ord) 58 | 59 | instance Outputable StackLocation where 60 | ppr (Local n) = text "local" <+> int n 61 | ppr (Incoming n) = text "in" <+> int n 62 | ppr (Outgoing n) = text "out" <+> int n 63 | 64 | data StaticLocation 65 | = Static Int -- global variable 66 | | SReg Int (Maybe Int) -- global register (+ label of initial value) 67 | | HSRam Int (Maybe Int) -- high-speed ram (+ label of initial value) 68 | deriving (Eq, Show, Ord) 69 | 70 | instance Outputable StaticLocation where 71 | ppr (Static n) = text "L." <> int n 72 | ppr (SReg n _) = text "global register" <+> int n 73 | ppr (HSRam n _) = text "high speed ram" <+> int n 74 | 75 | emptyReg :: Reg 76 | emptyReg = Reg { 77 | name = "", 78 | stamp = 0, 79 | loc = Unknown 80 | } 81 | 82 | emptyRegInfo :: RegInfo 83 | emptyRegInfo = RegInfo { 84 | spill = False, 85 | interf = [], 86 | prefer = [], 87 | degree = 0, 88 | spillCost = 0, 89 | visited = False, 90 | location = Unknown 91 | } 92 | 93 | instance Ord Reg where 94 | r1 `compare` r2 = stamp r1 `compare` stamp r2 95 | -------------------------------------------------------------------------------- /src/RegM.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module RegM where 7 | 8 | import Choco 9 | import CmmSyn 10 | import Reg 11 | 12 | import Control.Monad.State 13 | import qualified Data.Map as M 14 | 15 | newRegId = do 16 | id <- gets reg_stamp 17 | modify $ \e -> e{ reg_stamp = id + 1 } 18 | return id 19 | 20 | addReg :: Reg -> ChocoM () 21 | addReg reg = do 22 | env@CEnv{ reg_list = regs, reg_info_table = tab } <- get 23 | put env{ reg_list = reg:regs, 24 | reg_info_table = M.insert reg emptyRegInfo tab } 25 | 26 | createRegv :: Bool -> ChocoM [Reg] 27 | createRegv False = return [] 28 | createRegv True = createReg >>= return . (: []) 29 | 30 | createReg :: ChocoM Reg 31 | createReg = do 32 | id <- newRegId 33 | let r = emptyReg { 34 | stamp = id 35 | } 36 | addReg r 37 | return r 38 | 39 | copyReg :: Reg -> ChocoM Reg 40 | copyReg r = do 41 | new <- createReg 42 | i <- getRegInfo r 43 | modifyRegInfo new (const i) 44 | return new{ name = name r } 45 | 46 | 47 | getsRegInfo :: Reg -> (RegInfo -> a) -> ChocoM a 48 | getsRegInfo r f = getRegInfo r >>= return . f 49 | 50 | getRegInfo :: Reg -> ChocoM RegInfo 51 | getRegInfo r = gets reg_info_table >>= return . (M.! r) 52 | 53 | modifyRegInfo :: Reg -> (RegInfo -> RegInfo) -> ChocoM () 54 | modifyRegInfo r f = do 55 | e@CEnv{ reg_info_table = tab } <- get 56 | let info = tab M.! r 57 | put e{ reg_info_table = M.insert r (f info) tab } 58 | -------------------------------------------------------------------------------- /src/Reload.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Reload where 7 | 8 | import Choco 9 | import Mach 10 | import Outputable 11 | import Panic 12 | import Reg 13 | import RegM 14 | 15 | import Control.Monad.State 16 | 17 | type P a = StateT Bool ChocoM a 18 | 19 | accessStack :: [Reg] -> Bool 20 | accessStack (Reg{ loc = Stack _ }:rs) = True 21 | accessStack (_:rs) = accessStack rs 22 | accessStack [] = False 23 | 24 | insertMove dst src next 25 | | loc src == loc dst = next 26 | | otherwise = consInst (Iop Imove) [dst] [src] next 27 | 28 | insertMoves dst src next 29 | = foldr (\(d, s) n -> insertMove d s n) next (zip dst src) 30 | 31 | makeReg r = case loc r of 32 | Unknown -> lift$simpleError (text "Reload:makeReg") 33 | Register _ -> return r 34 | Stack _ -> do 35 | put True 36 | newr <- lift$copyReg r 37 | lift$modifyRegInfo newr $ \i -> i{ spillCost = 100000 } 38 | return newr 39 | 40 | makeRegs rv = mapM makeReg rv 41 | 42 | makeReg1 (r:rv) = makeReg r >>= return . (: rv) 43 | 44 | reloadOperation op res arg = case op of 45 | _ | op `elem` [Imove, Ireload, Ispill] 46 | -> case (res !! 0, arg !! 0) of 47 | (Reg{ loc = Stack s1 }, Reg{ loc = Stack s2 }) | s1 /= s2 48 | -> do r <- makeReg (arg!!0) 49 | return (res, [r]) 50 | _ -> return (res, arg) 51 | _ -> do arg' <- makeRegs arg 52 | res' <- makeRegs res 53 | return (res', arg') 54 | 55 | reload i = case idesc i of 56 | Iend -> return i 57 | Ireturn -> return i 58 | Iop (Itailcall_imm _) -> return i 59 | Iop Itailcall_ind -> do 60 | newarg <- makeReg1 (args i) 61 | return $ insertMoves newarg (args i) $ 62 | consInstLive (idesc i) (result i) newarg (live i) (next i) 63 | Iop (Icall_imm _) -> do 64 | next' <- reload (next i) 65 | return $ consInstLive (idesc i) (result i) (args i) (live i) next' 66 | Iop Icall_ind -> do 67 | newarg <- makeReg1 (args i) 68 | next' <- reload (next i) 69 | return $ insertMoves newarg (args i) $ 70 | consInstLive (idesc i) (result i) newarg (live i) next' 71 | 72 | Iop op -> do 73 | next' <- reload (next i) 74 | (newres, newarg) <- reloadOperation op (result i) (args i) 75 | return $ insertMoves newarg (args i) $ 76 | consInstLive (idesc i) newres newarg (live i) $ 77 | insertMoves (result i) newres next' 78 | 79 | Icond test ifso ifnot -> do 80 | newarg <- makeRegs (args i) 81 | ifso' <- reload ifso 82 | ifnot' <- reload ifnot 83 | next' <- reload (next i) 84 | return $ insertMoves newarg (args i) $ 85 | consInst (Icond test ifso' ifnot') [] newarg (next') 86 | 87 | fundecl f = evalStateT (do 88 | new_body <- reload (fun_body f) 89 | redo_regalloc <- get 90 | return (f{ fun_body = new_body }, redo_regalloc) 91 | ) False 92 | -------------------------------------------------------------------------------- /src/Spill.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Spill where 7 | 8 | import Choco 9 | import Mach 10 | import Outputable 11 | import Proc 12 | import Reg 13 | import RegM 14 | 15 | {- Insertion of moves to suggest possible spilling / reloading points 16 | before register allocation -} 17 | 18 | import Control.Monad.State 19 | import Data.List 20 | import qualified Data.Map as M 21 | import qualified Data.Set as S 22 | 23 | type P a = StateT Env ChocoM a 24 | type Subst = M.Map Reg Reg 25 | 26 | data Env = Env { 27 | spill_env :: Subst, -- Association of spill registers to registers 28 | use_date :: M.Map Reg Int, -- Record the position of last use of registers 29 | current_date :: Int, 30 | 31 | -- Destroyed at if-then-else points 32 | destroyed_at_fork :: [(Inst, S.Set Reg)] 33 | } 34 | 35 | initEnv = Env { 36 | spill_env = M.empty, 37 | use_date = M.empty, 38 | current_date = 0, 39 | destroyed_at_fork = [] 40 | } 41 | 42 | incrCurrentDate :: Int -> P () 43 | incrCurrentDate n = modify $ \e -> e{ current_date = (current_date e) + n } 44 | 45 | spillReg :: Reg -> P Reg 46 | spillReg r = do 47 | env <- gets spill_env 48 | case M.lookup r env of 49 | Just r' -> return r' 50 | Nothing -> do 51 | spill_r <- lift $ createReg 52 | lift $ modifyRegInfo spill_r $ \i -> i{ spill = True } 53 | let spill_r' = spill_r{ 54 | name = if name r /= "" 55 | then "spilled-" ++ name r 56 | else "" 57 | } 58 | modify $ \e -> e{ spill_env = M.insert r spill_r' (spill_env e) } 59 | return spill_r' 60 | 61 | recordUse :: [Reg] -> P () 62 | recordUse = 63 | mapM_ (\r -> do 64 | e@Env{ use_date = u, current_date = c } <- get 65 | let prev_date = M.findWithDefault 0 r u 66 | when (c > prev_date) $ 67 | put e{ use_date = M.insert r c u } 68 | ) 69 | 70 | 71 | -- Check if the register pressure overflows the maximum pressure allowed 72 | -- at that point. If so, spill enough registers to lower the pressure. 73 | addSuperPressureRegs op live_regs res_regs spilled = do 74 | let max_pressure = maxRegisterPressure op 75 | let regs = foldr S.insert live_regs res_regs 76 | -- Compute the pressure 77 | pressure <- foldM (\p r -> 78 | if S.member r spilled 79 | then return p 80 | else case loc r of 81 | Stack _ -> return p 82 | _ -> return (p+1) 83 | ) 0 (S.toList regs) 84 | -- Check if pressure is exceeded 85 | if pressure <= max_pressure 86 | then return spilled 87 | else do 88 | -- Find the least recently used, unspilled, unallocated, live register 89 | (lru_date, lru_reg) <- foldM (\(lrud, lrur) r -> 90 | if S.notMember r spilled && loc r == Unknown 91 | then do 92 | ud <- gets use_date 93 | case M.lookup r ud of 94 | Just d -> if d < lrud 95 | then return (d, r) 96 | else return (lrud, lrur) 97 | Nothing -> return (lrud, lrur) 98 | else return (lrud, lrur) 99 | ) (1000000, emptyReg) (S.toList live_regs) 100 | if lru_reg /= emptyReg 101 | then return $ S.insert lru_reg spilled 102 | else return spilled 103 | 104 | 105 | -- First pass: insert reload instructions based on an approximation of 106 | -- what is destroyed at pressure points 107 | addReloads regset i = 108 | foldM (\i r -> do 109 | spill_r <- spillReg r 110 | return $ consInst (Iop Ireload) [r] [spill_r] i 111 | ) i (S.toList regset) 112 | 113 | 114 | reload i before = do 115 | incrCurrentDate 1 116 | recordUse (args i) 117 | recordUse (result i) 118 | case idesc i of 119 | Iend -> return (i, before) 120 | 121 | Ireturn -> do 122 | i' <- addReloads (before `S.intersection` (S.fromList$args i)) i 123 | return (i', S.empty) 124 | 125 | Iop Itailcall_ind -> do 126 | i' <- addReloads (before `S.intersection` (S.fromList$args i)) i 127 | return (i', S.empty) 128 | 129 | Iop (Itailcall_imm _) -> do 130 | i' <- addReloads (before `S.intersection` (S.fromList$args i)) i 131 | return (i', S.empty) 132 | 133 | Iop Icall_ind -> do 134 | (new_next, finally) <- reload (next i) (live i) 135 | i' <- addReloads (before `S.intersection` (S.fromList$args i)) 136 | (consInst (Iop Icall_ind) (result i) (args i) new_next) 137 | return (i', finally) 138 | 139 | Iop (Icall_imm s) -> do 140 | (new_next, finally) <- reload (next i) (live i) 141 | i' <- addReloads (before `S.intersection` (S.fromList$args i)) 142 | (consInst (Iop (Icall_imm s)) (result i) (args i) new_next) 143 | return (i', finally) 144 | 145 | Iop op -> do 146 | new_before <- 147 | if S.size (live i) + length (result i) <= safeRegisterPressure op 148 | then return before 149 | else addSuperPressureRegs op (live i) (result i) before 150 | let after = new_before S.\\ (S.fromList (args i)) 151 | S.\\ (S.fromList (result i)) 152 | 153 | (new_next, finally) <- reload (next i) after 154 | i' <- addReloads (new_before `S.intersection` (S.fromList$args i)) 155 | (consInst (Iop op) (result i) (args i) new_next) 156 | return (i', finally) 157 | 158 | Icond tst ifso ifnot -> do 159 | let at_fork = before S.\\ (S.fromList (args i)) 160 | date_fork <- gets current_date 161 | (new_ifso, after_ifso) <- reload ifso at_fork 162 | date_ifso <- gets current_date 163 | modify $ \e -> e{ current_date = date_fork } 164 | 165 | (new_ifnot, after_ifnot) <- reload ifnot at_fork 166 | modify $ \e -> e{ current_date = max date_ifso (current_date e) } 167 | 168 | (new_next, finally) <- 169 | reload (next i) (after_ifso `S.union` after_ifnot) 170 | 171 | let new_i = consInst (Icond tst new_ifso new_ifnot) 172 | (result i) (args i) new_next 173 | 174 | modify $ \e -> e{ 175 | destroyed_at_fork = (new_i, at_fork) : (destroyed_at_fork e) 176 | } 177 | 178 | i' <- addReloads (before `S.intersection` (S.fromList$args i)) new_i 179 | return (i', finally) 180 | 181 | 182 | -- Second pass: add spill instructions based on what we've decided to reload. 183 | -- That is, any register that may be reloaded in the future must be spilled 184 | -- just after its definition 185 | addSpills regset i = 186 | foldM (\i r -> do 187 | spill_r <- spillReg r 188 | return $ consInst (Iop Ispill) [spill_r] [r] i 189 | ) i (S.toList regset) 190 | 191 | doSpill :: Inst -> S.Set Reg -> P (Inst, S.Set Reg) 192 | doSpill i finally = 193 | case idesc i of 194 | Iend -> return (i, finally) 195 | 196 | Ireturn -> return (i, S.empty) 197 | Iop Itailcall_ind -> return (i, S.empty) 198 | Iop (Itailcall_imm _) -> return (i, S.empty) 199 | 200 | Iop Ireload -> do 201 | (new_next, after) <- doSpill (next i) finally 202 | let before' = after S.\\ (S.fromList $ result i) 203 | return 204 | (consInst (Iop Ireload) (result i) (args i) new_next, 205 | S.union before' (S.fromList$result i)) 206 | 207 | Iop _ -> do 208 | (new_next, after) <- doSpill (next i) finally 209 | let before = after S.\\ (S.fromList $ result i) 210 | next' <- addSpills (after `S.intersection` (S.fromList $ result i)) new_next 211 | return (consInst (idesc i) (result i) (args i) next', before) 212 | 213 | Icond tst ifso ifnot -> do 214 | (new_next, at_join) <- doSpill (next i) finally 215 | (new_ifso, before_ifso) <- doSpill ifso at_join 216 | (new_ifnot, before_ifnot) <- doSpill ifnot at_join 217 | 218 | tab <- gets destroyed_at_fork 219 | Just destroyed <- return . lookup i =<< gets destroyed_at_fork 220 | 221 | let spill_ifso_branch = before_ifso S.\\ before_ifnot S.\\ destroyed 222 | let spill_ifnot_branch = before_ifnot S.\\ before_ifso S.\\ destroyed 223 | 224 | ifso' <- addSpills spill_ifso_branch new_ifso 225 | ifnot' <- addSpills spill_ifnot_branch new_ifnot 226 | return 227 | (consInst (Icond tst ifso' ifnot') (result i) (args i) new_next, 228 | (before_ifso `S.union` before_ifnot) 229 | S.\\ spill_ifso_branch S.\\ spill_ifnot_branch) 230 | 231 | 232 | -- Entry point 233 | fundecl :: FunDec -> ChocoM FunDec 234 | fundecl f = evalStateT (do 235 | (body1, _) <- reload (fun_body f) S.empty 236 | (body2, tospill_at_entry) <- doSpill body1 S.empty 237 | new_body <- addSpills 238 | (tospill_at_entry `S.intersection` S.fromList (fun_args f)) body2 239 | return f{ fun_body = new_body } 240 | ) initEnv 241 | -------------------------------------------------------------------------------- /src/Split.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Split where 7 | 8 | import Choco 9 | import Mach 10 | import Outputable 11 | import Reg 12 | import RegM 13 | 14 | import Control.Monad.State 15 | import qualified Data.Map as M 16 | import qualified Data.Set as S 17 | 18 | {- Renaming of registers at reload points to split live ranges -} 19 | 20 | type P a = StateT Env ChocoM a 21 | type Subst = M.Map Reg Reg 22 | 23 | data Env = Env { 24 | equiv_classes :: Subst 25 | } 26 | 27 | initEnv = Env { 28 | equiv_classes = M.empty 29 | } 30 | 31 | substReg :: Subst -> Reg -> Reg 32 | substReg sub r = M.findWithDefault r r sub 33 | 34 | substRegs :: Maybe Subst -> [Reg] -> [Reg] 35 | substRegs sub rv = 36 | case sub of 37 | Nothing -> rv 38 | Just s -> map (substReg s) rv 39 | 40 | repres_reg :: Reg -> P Reg 41 | repres_reg r = do 42 | e <- gets equiv_classes 43 | case M.lookup r e of 44 | Just r' -> repres_reg r' 45 | Nothing -> return r 46 | 47 | repres_regs :: [Reg] -> P [Reg] 48 | repres_regs rv = mapM repres_reg rv 49 | 50 | identify :: Reg -> Reg -> P () 51 | identify r1 r2 = do 52 | repres1 <- repres_reg r1 53 | repres2 <- repres_reg r2 54 | when (stamp repres1 /= stamp repres2) $ 55 | modify $ \e -> e{ 56 | equiv_classes = M.insert repres1 repres2 (equiv_classes e) 57 | } 58 | 59 | identifySub :: Subst -> Subst -> Reg -> P () 60 | identifySub sub1 sub2 reg = do 61 | case M.lookup reg sub1 of 62 | Just r1 -> case M.lookup reg sub2 of 63 | Just r2 -> identify r1 r2 64 | Nothing -> identify r1 reg 65 | Nothing -> case M.lookup reg sub2 of 66 | Just r2 -> identify r2 reg 67 | Nothing -> return () 68 | 69 | mergeSubsts :: Maybe Subst -> Maybe Subst -> Inst -> P (Maybe Subst) 70 | mergeSubsts sub1 sub2 i = 71 | case (sub1, sub2) of 72 | (Nothing, Nothing) -> return Nothing 73 | (Just _, Nothing) -> return sub1 74 | (Nothing, Just _) -> return sub2 75 | (Just s1, Just s2) -> do 76 | mapM_ (identifySub s1 s2) $ 77 | S.toList (S.union (live i) (S.fromList $ args i)) 78 | return sub1 79 | 80 | rename :: Inst -> Maybe Subst -> P (Inst, Maybe Subst) 81 | rename i subst = 82 | case idesc i of 83 | Iend -> return (i, subst) 84 | Ireturn -> return 85 | (consInst (idesc i) [] (substRegs subst (args i)) (next i), Nothing) 86 | Iop Itailcall_ind -> return 87 | (consInst (idesc i) [] (substRegs subst (args i)) (next i), Nothing) 88 | Iop (Itailcall_imm _) -> return 89 | (consInst (idesc i) [] (substRegs subst (args i)) (next i), Nothing) 90 | Iop Ireload | loc (result i !! 0) == Unknown -> 91 | case subst of 92 | Nothing -> rename (next i) subst 93 | Just s -> do 94 | let older = result i !! 0 95 | newer <- lift $ copyReg older 96 | (new_next, sub_next) <- 97 | rename (next i) (Just $ M.insert older newer s) 98 | return (consInst (idesc i) [newer] (args i) new_next, sub_next) 99 | Iop _ -> do 100 | (new_next, sub_next) <- rename (next i) subst 101 | return (consInst (idesc i) 102 | (substRegs subst (result i)) 103 | (substRegs subst (args i)) 104 | new_next, 105 | sub_next) 106 | Icond tst ifso ifnot -> do 107 | (new_ifso, sub_ifso) <- rename ifso subst 108 | (new_ifnot, sub_ifnot) <- rename ifnot subst 109 | (new_next, sub_next) <- 110 | rename (next i) =<< mergeSubsts sub_ifso sub_ifnot (next i) 111 | return (consInst (Icond tst new_ifso new_ifnot) 112 | [] 113 | (substRegs subst (args i)) 114 | new_next, 115 | sub_next) 116 | 117 | set_repres i = 118 | instIter (\i -> do 119 | new_args <- repres_regs (args i) 120 | new_result <- repres_regs (result i) 121 | return i{ args = new_args, result = new_result } 122 | ) i 123 | 124 | fundecl :: FunDec -> ChocoM FunDec 125 | fundecl f = evalStateT (do 126 | (new_body, sub_body) <- rename (fun_body f) (Just M.empty) 127 | new_args <- repres_regs (fun_args f) 128 | new_body' <- set_repres new_body 129 | return f{ fun_args = new_args, fun_body = new_body' } 130 | ) initEnv 131 | -------------------------------------------------------------------------------- /src/SrcLoc.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module SrcLoc ( 7 | SrcLoc, -- abstract 8 | sL, mkSrcLoc, noSrcLoc, 9 | advanceSrcLoc, startSrcLoc, combineSrcLoc, 10 | Located(..), 11 | unLoc, getLoc 12 | ) where 13 | 14 | import Outputable 15 | import Panic 16 | 17 | {- source location -} 18 | 19 | data SrcLoc 20 | = SrcLoc { 21 | srcLocLine :: !Int, -- line number, 1 origin 22 | srcLocCol :: !Int -- column number, 0 origin 23 | } 24 | | SrcSpan { 25 | srcSpanSLine :: !Int, -- start line 26 | srcSpanSCol :: !Int, -- start column 27 | srcSpanELine :: !Int, -- end line 28 | srcSpanECol :: !Int -- end column 29 | } 30 | | UnhelpfulLoc String 31 | deriving (Eq) 32 | 33 | {-# INLINE sL #-} 34 | sL :: SrcLoc -> a -> Located a 35 | sL loc a = loc `seq` L loc a 36 | 37 | mkSrcLoc line col = SrcLoc line col 38 | noSrcLoc = UnhelpfulLoc "" 39 | 40 | advanceSrcLoc :: SrcLoc -> Char -> SrcLoc 41 | advanceSrcLoc (SrcLoc l _) '\n' = SrcLoc (l+1) 0 42 | advanceSrcLoc (SrcLoc l c) _ = SrcLoc l (c+1) 43 | advanceSrcLoc loc _ = loc 44 | 45 | startSrcLoc = mkSrcLoc 1 0 46 | 47 | combineSrcLoc :: SrcLoc -> SrcLoc -> SrcLoc 48 | combineSrcLoc (SrcLoc sl sc) (SrcLoc el ec) 49 | = SrcSpan sl sc el ec 50 | combineSrcLoc (SrcLoc sl sc) (SrcSpan _ _ el ec) 51 | = SrcSpan sl sc el ec 52 | combineSrcLoc (SrcSpan sl sc _ _) (SrcLoc el ec) 53 | = SrcSpan sl sc el ec 54 | combineSrcLoc (SrcSpan sl sc _ _) (SrcSpan _ _ el ec) 55 | = SrcSpan sl sc el ec 56 | combineSrcLoc _ _ = panic "combineSrcLoc" 57 | 58 | instance Outputable SrcLoc where 59 | ppr (SrcLoc l c) = ppr (l,c) 60 | ppr (SrcSpan sl sc el ec) = ppr (sl,sc) <> char '-' <> ppr (el,ec) 61 | ppr (UnhelpfulLoc str) = text str 62 | 63 | instance Show SrcLoc where 64 | show l = show $ ppr l 65 | 66 | ------------------------------------------------------------ 67 | -- The location info wrapper 68 | ------------------------------------------------------------ 69 | 70 | data Located e = L SrcLoc e 71 | deriving (Eq) 72 | 73 | unLoc (L _ e) = e 74 | getLoc (L loc _) = loc 75 | 76 | 77 | instance (Outputable e) => Outputable (Located e) where 78 | ppr = ppr.unLoc 79 | 80 | instance (Show e) => Show (Located e) where 81 | show = show.unLoc 82 | -------------------------------------------------------------------------------- /src/TcSyn.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module TcSyn ( 7 | TcPat(..), TcPatDesc(..), 8 | TcExpr(..), TcExprDesc(..), 9 | TcStmt(..), LTcStmt 10 | ) where 11 | 12 | import Common 13 | import Const 14 | import McSyn 15 | import Outputable 16 | import Panic 17 | import SrcLoc 18 | import Types 19 | import Var 20 | 21 | import Data.List 22 | import qualified Data.IntSet as S 23 | 24 | {- Abstract syntax after typing -} 25 | 26 | data TcPat = TcPat { 27 | pat_desc :: TcPatDesc, 28 | pat_loc :: SrcLoc, 29 | pat_type :: Type 30 | } 31 | deriving (Eq) 32 | 33 | data TcPatDesc 34 | = TcAnyP 35 | | TcVarP Var 36 | | TcTupleP [TcPat] 37 | deriving (Eq) 38 | 39 | data TcExpr = TcExpr { 40 | expr_desc :: TcExprDesc, 41 | expr_loc :: SrcLoc, 42 | expr_type :: Type 43 | } 44 | deriving (Eq) 45 | 46 | data TcExprDesc 47 | = TcVarE Var 48 | | TcLitE Const 49 | | TcAppE TcExpr [TcExpr] 50 | | TcPrefixE PreOp TcExpr 51 | | TcInfixE BinOp TcExpr TcExpr 52 | | TcLetE RecFlag (TcPat, TcExpr) TcExpr 53 | | TcFunE [TcPat] TcExpr 54 | | TcTupleE [TcExpr] 55 | | TcCondE TcExpr TcExpr TcExpr 56 | | TcSeqE TcExpr TcExpr 57 | deriving (Eq) 58 | 59 | data TcStmt 60 | = TcEvalS TcExpr 61 | | TcValueS (TcPat, TcExpr) 62 | deriving (Eq) 63 | 64 | type LTcStmt = Located TcStmt 65 | 66 | instance Show TcPat where 67 | show = show.ppr 68 | instance Outputable TcPat where 69 | ppr = pprPat [] 70 | 71 | instance Show TcExpr where 72 | show = show.ppr 73 | instance Outputable TcExpr where 74 | ppr = pprExpr [] 75 | 76 | instance Show TcStmt where 77 | show = show.ppr 78 | instance Outputable TcStmt where 79 | ppr stmt = pprStmt stmt 80 | 81 | pprVar m v@Var{ var_type = TyScheme _ ty } 82 | = ppr v <> brackets (pprTy m ty) 83 | 84 | pprPat _ TcPat{ pat_desc = TcAnyP } = char '_' 85 | pprPat m TcPat{ pat_desc = TcVarP v } = pprVar m v 86 | pprPat m TcPat{ pat_desc = TcTupleP elems } 87 | = parens.sep $ punctuate comma (map (pprPat m) elems) 88 | 89 | pprExpr m TcExpr{ expr_desc = TcVarE v } = pprVar m v 90 | pprExpr _ TcExpr{ expr_desc = TcLitE c } = ppr c 91 | pprExpr m TcExpr{ expr_desc = TcAppE f args } 92 | = hang (pprExpr m f) 2 (sep (map (pprParendExpr m) args)) 93 | pprExpr m TcExpr{ expr_desc = TcPrefixE op e } 94 | = ppr op <+> pprParendExpr m e 95 | pprExpr m TcExpr{ expr_desc = TcInfixE op e1 e2 } 96 | = pprParendExpr m e1 <+> ppr op <+> pprParendExpr m e2 97 | pprExpr m TcExpr{ expr_desc = TcLetE rec bind e } 98 | = let letstr = case rec of 99 | Rec -> text "let rec"; NonRec -> text "let" 100 | in sep [hang letstr 2 (pprBind bind), 101 | text "in", 102 | pprExpr m e] 103 | pprExpr m TcExpr{ expr_desc = TcFunE args body } 104 | = sep [hsep (text "fun" : 105 | intersperse (text "->") (map (pprPat m) args)) <+> text "->", 106 | nest 2 (pprExpr m body)] 107 | pprExpr m TcExpr{ expr_desc = TcTupleE elems } 108 | = parens.sep $ punctuate comma (map (pprExpr m) elems) 109 | pprExpr m TcExpr{ expr_desc = TcCondE e1 e2 e3 } 110 | = sep [hsep [text "if", nest 2 (pprExpr m e1)], 111 | nest 2 (text "then" <+> pprExpr m e2), 112 | nest 2 (text "else" <+> pprExpr m e3) 113 | ] 114 | pprExpr m TcExpr{ expr_desc = TcSeqE e1 e2 } 115 | = pprExpr m e1 <> semi $$ pprExpr m e2 116 | 117 | pprBind (pat, expr) 118 | = let m = [] -- zip (S.toList $ grepIds (pat_desc pat)) ['a'..] 119 | in pprPat m pat <+> char '=' <+> pprExpr m expr 120 | where 121 | grepIds TcAnyP = S.empty 122 | grepIds (TcVarP (Var{ var_type = TyScheme ids _ })) = ids 123 | grepIds (TcTupleP pats) = S.unions $ map (grepIds . pat_desc) pats 124 | 125 | pprParendExpr m expr 126 | = let pp = pprExpr m expr 127 | in case expr_desc expr of 128 | TcVarE _ -> pp 129 | TcLitE _ -> pp 130 | _ -> parens pp 131 | 132 | pprStmt (TcEvalS e) = ppr e 133 | pprStmt (TcValueS bind) = text "let" <+> pprBind bind 134 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Types ( 7 | TyId, Type(..), TyIdSet, TyScheme(..), 8 | toScheme, freeVar, freeVarTySc, 9 | 10 | arrayElemSize, typeSize, 11 | 12 | pprTy, schemeDebugPrint, 13 | align, getShift 14 | ) where 15 | 16 | import Id 17 | import Outputable 18 | import Panic 19 | 20 | import Data.Bits 21 | import Data.List 22 | import qualified Data.IntSet as S 23 | import qualified Data.IntMap as M 24 | import Text.Printf 25 | 26 | type TyId = Id 27 | type TyIdSet = S.IntSet 28 | 29 | data Type 30 | = UnitT 31 | | BoolT 32 | | IntT 33 | | FloatT 34 | | FunT [Type] Type 35 | | TupleT [Type] 36 | | ArrayT Type 37 | | TyVar !TyId 38 | | UnknownT 39 | deriving (Eq, Show) 40 | 41 | arrayElemSize :: Type -> Int 42 | arrayElemSize (TupleT ts) = align $ sum $ map arrayElemSize ts 43 | arrayElemSize _ = 1 44 | 45 | typeSize :: Type -> Int 46 | typeSize (TupleT ts) = sum $ map typeSize ts 47 | typeSize _ = 1 48 | 49 | -- move to another source file later 50 | -- fixme! 51 | align n = iter 1 52 | where 53 | iter x 54 | | n <= x = x 55 | | otherwise = iter (2 * x) 56 | 57 | getShift n = iter 1 0 58 | where 59 | iter x s 60 | | n <= x = s 61 | | otherwise = iter (2 * x) (s + 1) 62 | 63 | 64 | data TyScheme = TyScheme TyIdSet Type 65 | 66 | toScheme ty = TyScheme S.empty ty 67 | 68 | freeVar :: Type -> TyIdSet 69 | freeVar (FunT args ret) = S.unions $ map freeVar (ret:args) 70 | freeVar (TupleT ts) = S.unions $ map freeVar ts 71 | freeVar (ArrayT t) = freeVar t 72 | freeVar (TyVar id) = S.singleton id 73 | freeVar _ = S.empty 74 | 75 | freeVarTySc :: TyScheme -> TyIdSet 76 | freeVarTySc (TyScheme ids ty) = freeVar ty S.\\ ids 77 | 78 | instance Outputable Type where 79 | ppr UnitT = text "unit" 80 | ppr BoolT = text "bool" 81 | ppr IntT = text "int" 82 | ppr FloatT = text "float" 83 | ppr UnknownT = text "?" 84 | ppr (FunT args ret) = 85 | hsep $ intersperse (text "->") (map ppr (args++[ret])) 86 | ppr (TupleT ts) = parens.hsep $ punctuate comma (map ppr ts) 87 | ppr (ArrayT e) = ppr e <> char '*' 88 | ppr (TyVar i) = char 'v' <> pprId i 89 | 90 | instance Outputable TyScheme where 91 | ppr (TyScheme ids ty) = ppr ty 92 | 93 | instance Show TyScheme where 94 | show = show.ppr 95 | 96 | pprTy :: [(TyId, Char)] -> Type -> Doc 97 | pprTy m t@(TyVar id) = 98 | case lookup id m of 99 | Just c -> char c 100 | Nothing -> ppr t 101 | pprTy m (FunT args ret) = 102 | hsep $ intersperse (text "->") (map (pprTy m) (args ++ [ret])) 103 | pprTy m (TupleT ts) = parens.hsep $ punctuate comma (map (pprTy m) ts) 104 | pprTy m (ArrayT e) = pprTy m e <> char '*' 105 | pprTy m t = ppr t 106 | 107 | schemeDebugPrint :: TyScheme -> IO () 108 | schemeDebugPrint (TyScheme ids ty) 109 | = do printf "forall %s -> %s\n" (show $ S.toList ids) (show ty) 110 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util ( 2 | catchMaybe 3 | ) where 4 | 5 | catchMaybe :: Monad m => m (Maybe a) -> m a -> m a 6 | catchMaybe m f 7 | = do x <- m 8 | case x of 9 | Just x' -> return x' 10 | Nothing -> f 11 | -------------------------------------------------------------------------------- /src/Var.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Var ( 7 | Name, -- abstract 8 | mkName, unName, 9 | Var(..), mkVar, mkTmpVar, mkGlobalVar, copyVar, isGlobal, toSymbol, 10 | VarMap, mkIdent 11 | ) where 12 | 13 | import Choco 14 | import Id 15 | import Outputable 16 | import Types 17 | 18 | import Data.Function 19 | import qualified Data.Map as M 20 | import Data.Maybe 21 | 22 | {- name only -} 23 | data Name = Name !String 24 | deriving (Eq, Ord) 25 | 26 | mkName :: String -> Name 27 | mkName name = Name name 28 | 29 | unName :: Name -> String 30 | unName (Name name) = name 31 | 32 | 33 | instance Outputable Name where 34 | ppr (Name name) = text name 35 | 36 | instance Show Name where 37 | show = show.ppr 38 | 39 | 40 | {- variable -} 41 | data Var = Var { 42 | var_name :: String, 43 | var_id :: Id, 44 | var_type :: TyScheme, 45 | is_global :: Bool 46 | } 47 | 48 | instance Eq Var where 49 | (==) = (==) `on` var_id 50 | 51 | instance Ord Var where 52 | compare = compare `on` var_id 53 | 54 | instance Outputable Var where 55 | ppr (Var name id ty False) = text name <> char '_' <> int id 56 | ppr (Var name id ty True) = char 'G' <> text name <> char '_' <> int id 57 | 58 | instance Show Var where 59 | show = show.ppr 60 | 61 | mkVar :: String -> Id -> TyScheme -> Bool -> Var 62 | mkVar name id ty gbl = Var { 63 | var_name = name, 64 | var_id = id, 65 | var_type = ty, 66 | is_global = gbl 67 | } 68 | 69 | mkTmpVar :: String -> TyScheme -> ChocoM Var 70 | mkTmpVar name ty 71 | = do id <- newUniq 72 | return $ mkVar name id ty False 73 | 74 | mkGlobalVar :: String -> TyScheme -> ChocoM Var 75 | mkGlobalVar name ty 76 | = do id <- newUniq 77 | return $ mkVar name id ty True 78 | 79 | copyVar :: Var -> ChocoM Var 80 | copyVar v = do id <- newUniq 81 | return $ mkVar (var_name v) id (var_type v) (is_global v) 82 | 83 | isGlobal :: Var -> Bool 84 | isGlobal v = is_global v 85 | 86 | -- generate unique string 87 | toSymbol :: Var -> String 88 | toSymbol v = var_name v ++ "_" ++ show (var_id v) 89 | 90 | mkIdent :: String -> ChocoM String 91 | mkIdent name = do 92 | id <- newUniq 93 | return (name ++ "!" ++ show id) 94 | 95 | type VarMap = M.Map Name (TyScheme, Id, Bool) 96 | -------------------------------------------------------------------------------- /testcodes/arraytest1.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 20:56:47 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | 10 | entry_point1007: 11 | L.1008: 12 | li r3 a_1000; 13 | calli fill_1001; 14 | li r4 0; 15 | loadi r2 r0 (a_1000 + 9); 16 | nop; 17 | put r2; 18 | ret; 19 | nop; 20 | L.1009: 21 | halt; 22 | jumpi L.1009; 23 | nop; 24 | fill_1001: 25 | L.1010: 26 | bli r4 10 L.99; 27 | ret; 28 | nop; 29 | L.99: 30 | adds r2 r3 r4; 31 | muliu r39 r4 2; 32 | storei r2 r39 0; 33 | jumpi L.1010; 34 | addiu r4 r4 1; 35 | a_1000: 36 | .int 0; 37 | .int 0; 38 | .int 0; 39 | .int 0; 40 | .int 0; 41 | .int 0; 42 | .int 0; 43 | .int 0; 44 | .int 0; 45 | .int 0; 46 | /* constants */ 47 | /* Code end */ 48 | -------------------------------------------------------------------------------- /testcodes/arraytest1.ml: -------------------------------------------------------------------------------- 1 | let a = create_array 10 0 2 | 3 | let rec fill a n = 4 | if n >= 10 5 | then () 6 | else (a.(n) <- 2 * n; fill a (n + 1)) 7 | 8 | let _ = (fill a 0; print_char a.(9)) 9 | -------------------------------------------------------------------------------- /testcodes/arraytest2-noopt.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Wed Jan 23 02:59:04 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | 10 | entry_point1002: 11 | L.1003: 12 | li r3 40; 13 | calli create_array; 14 | li r4 0; 15 | li r39 30; 16 | li r3 20; 17 | li r4 10; 18 | li r5 0; 19 | storei r5 r2 0; 20 | storei r4 r2 1; 21 | storei r3 r2 2; 22 | storei r39 r2 3; 23 | li r39 40; 24 | li r4 90; 25 | li r5 80; 26 | li r6 70; 27 | li r7 60; 28 | li r8 50; 29 | li r9 40; 30 | li r10 30; 31 | li r11 20; 32 | li r12 10; 33 | li r13 0; 34 | li r14 90; 35 | li r15 80; 36 | li r16 70; 37 | li r17 60; 38 | li r18 50; 39 | li r19 40; 40 | li r20 30; 41 | li r21 20; 42 | li r22 10; 43 | li r23 0; 44 | li r24 90; 45 | li r25 80; 46 | li r26 70; 47 | li r27 60; 48 | li r28 50; 49 | li r29 40; 50 | li r30 30; 51 | li r31 20; 52 | li r32 10; 53 | li r33 0; 54 | li r34 90; 55 | li r35 80; 56 | li r36 70; 57 | li r37 60; 58 | li r38 50; 59 | storei r39 r2 4; 60 | storei r38 r2 5; 61 | storei r37 r2 6; 62 | storei r36 r2 7; 63 | storei r35 r2 8; 64 | storei r34 r2 9; 65 | storei r33 r2 10; 66 | storei r32 r2 11; 67 | storei r31 r2 12; 68 | storei r30 r2 13; 69 | storei r29 r2 14; 70 | storei r28 r2 15; 71 | storei r27 r2 16; 72 | storei r26 r2 17; 73 | storei r25 r2 18; 74 | storei r24 r2 19; 75 | storei r23 r2 20; 76 | storei r22 r2 21; 77 | storei r21 r2 22; 78 | storei r20 r2 23; 79 | storei r19 r2 24; 80 | storei r18 r2 25; 81 | storei r17 r2 26; 82 | storei r16 r2 27; 83 | storei r15 r2 28; 84 | storei r14 r2 29; 85 | storei r13 r2 30; 86 | storei r12 r2 31; 87 | storei r11 r2 32; 88 | storei r10 r2 33; 89 | storei r9 r2 34; 90 | storei r8 r2 35; 91 | storei r7 r2 36; 92 | storei r6 r2 37; 93 | storei r5 r2 38; 94 | storei r4 r2 39; 95 | loadi r3 r2 8; 96 | nop; 97 | put r3; 98 | L.1004: 99 | halt; 100 | jumpi L.1004; 101 | nop; 102 | /* constants */ 103 | /* Code end */ 104 | -------------------------------------------------------------------------------- /testcodes/arraytest2.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Thu Jan 24 08:15:39 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | li r61 1023; 9 | slliu r61 r61 2; 10 | addiu r60 r61 908; 11 | calli lib_const_load; 12 | /* initialize constants */ 13 | entry_point1042: 14 | L.1043: 15 | li r6 0; 16 | li r6 80; 17 | put r6; 18 | L.1044: 19 | halt; 20 | jumpi L.1044; 21 | nop; 22 | /* constants */ 23 | /* Code end */ -------------------------------------------------------------------------------- /testcodes/arraytest2.ml: -------------------------------------------------------------------------------- 1 | let a = create_array 40 0 in 2 | a.(0) <- 0; 3 | a.(1) <- 10; 4 | a.(2) <- 20; 5 | a.(3) <- 30; 6 | a.(4) <- 40; 7 | a.(5) <- 50; 8 | a.(6) <- 60; 9 | a.(7) <- 70; 10 | a.(8) <- 80; 11 | a.(9) <- 90; 12 | a.(10) <- 0; 13 | a.(11) <- 10; 14 | a.(12) <- 20; 15 | a.(13) <- 30; 16 | a.(14) <- 40; 17 | a.(15) <- 50; 18 | a.(16) <- 60; 19 | a.(17) <- 70; 20 | a.(18) <- 80; 21 | a.(19) <- 90; 22 | a.(20) <- 0; 23 | a.(21) <- 10; 24 | a.(22) <- 20; 25 | a.(23) <- 30; 26 | a.(24) <- 40; 27 | a.(25) <- 50; 28 | a.(26) <- 60; 29 | a.(27) <- 70; 30 | a.(28) <- 80; 31 | a.(29) <- 90; 32 | a.(30) <- 0; 33 | a.(31) <- 10; 34 | a.(32) <- 20; 35 | a.(33) <- 30; 36 | a.(34) <- 40; 37 | a.(35) <- 50; 38 | a.(36) <- 60; 39 | a.(37) <- 70; 40 | a.(38) <- 80; 41 | a.(39) <- 90; 42 | print_char a.(8) 43 | -------------------------------------------------------------------------------- /testcodes/arraytest3.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Wed Jan 23 03:05:17 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | loadi r63 r0 L.1343; 10 | nop; 11 | hsw r63 0; 12 | 13 | entry_point1342: 14 | L.1369: 15 | calli create_pixel_1003; 16 | nop; 17 | calli create_pixel_1003; 18 | nop; 19 | L.1370: 20 | halt; 21 | jumpi L.1370; 22 | nop; 23 | create_pixel_1003: 24 | subiu r1 r1 4; 25 | L.1371: 26 | li r3 3; 27 | hsr r4 0; 28 | calli create_array; 29 | nop; 30 | li r3 5; 31 | calli create_array; 32 | move r4 r2; 33 | li r3 3; 34 | hsr r4 0; 35 | storei r2 r1 0; 36 | calli create_array; 37 | nop; 38 | loadi r23 r1 0; 39 | li r3 3; 40 | storei r2 r23 1; 41 | hsr r4 0; 42 | calli create_array; 43 | nop; 44 | loadi r22 r1 0; 45 | li r3 3; 46 | storei r2 r22 2; 47 | hsr r4 0; 48 | calli create_array; 49 | nop; 50 | loadi r21 r1 0; 51 | li r3 3; 52 | storei r2 r21 3; 53 | hsr r4 0; 54 | calli create_array; 55 | nop; 56 | loadi r20 r1 0; 57 | li r3 3; 58 | storei r2 r20 4; 59 | storei r20 r1 1; 60 | hsr r4 0; 61 | calli create_array; 62 | nop; 63 | li r3 5; 64 | calli create_array; 65 | move r4 r2; 66 | li r3 3; 67 | hsr r4 0; 68 | storei r2 r1 0; 69 | calli create_array; 70 | nop; 71 | loadi r19 r1 0; 72 | li r3 3; 73 | storei r2 r19 1; 74 | hsr r4 0; 75 | calli create_array; 76 | nop; 77 | loadi r18 r1 0; 78 | li r3 3; 79 | storei r2 r18 2; 80 | hsr r4 0; 81 | calli create_array; 82 | nop; 83 | loadi r17 r1 0; 84 | li r3 3; 85 | storei r2 r17 3; 86 | hsr r4 0; 87 | calli create_array; 88 | nop; 89 | loadi r16 r1 0; 90 | li r3 3; 91 | storei r2 r16 4; 92 | storei r16 r1 2; 93 | hsr r4 0; 94 | calli create_array; 95 | nop; 96 | li r3 5; 97 | calli create_array; 98 | move r4 r2; 99 | li r3 3; 100 | hsr r4 0; 101 | storei r2 r1 0; 102 | calli create_array; 103 | nop; 104 | loadi r15 r1 0; 105 | li r3 3; 106 | storei r2 r15 1; 107 | hsr r4 0; 108 | calli create_array; 109 | nop; 110 | loadi r14 r1 0; 111 | li r3 3; 112 | storei r2 r14 2; 113 | hsr r4 0; 114 | calli create_array; 115 | nop; 116 | loadi r13 r1 0; 117 | li r3 3; 118 | storei r2 r13 3; 119 | hsr r4 0; 120 | calli create_array; 121 | nop; 122 | loadi r12 r1 0; 123 | li r3 3; 124 | storei r2 r12 4; 125 | storei r12 r1 3; 126 | hsr r4 0; 127 | calli create_array; 128 | nop; 129 | li r3 5; 130 | calli create_array; 131 | move r4 r2; 132 | li r3 3; 133 | hsr r4 0; 134 | storei r2 r1 0; 135 | calli create_array; 136 | nop; 137 | loadi r11 r1 0; 138 | li r3 3; 139 | storei r2 r11 1; 140 | hsr r4 0; 141 | calli create_array; 142 | nop; 143 | loadi r10 r1 0; 144 | li r3 3; 145 | storei r2 r10 2; 146 | hsr r4 0; 147 | calli create_array; 148 | nop; 149 | loadi r9 r1 0; 150 | li r3 3; 151 | storei r2 r9 3; 152 | hsr r4 0; 153 | calli create_array; 154 | nop; 155 | loadi r8 r1 0; 156 | li r3 1; 157 | storei r2 r8 4; 158 | storei r8 r1 3; 159 | calli create_array; 160 | li r4 0; 161 | li r3 5; 162 | loadi r4 r0 L.1348; 163 | storei r2 r1 3; 164 | calli create_array; 165 | nop; 166 | li r3 5; 167 | li r4 0; 168 | storei r2 r1 1; 169 | calli create_array; 170 | nop; 171 | li r3 3; 172 | hsr r4 0; 173 | storei r2 r1 1; 174 | calli create_array; 175 | nop; 176 | move r25 r2; 177 | move r2 r62; 178 | addiu r62 r62 8; 179 | loadi r39 r1 3; 180 | loadi r3 r1 3; 181 | loadi r4 r1 2; 182 | loadi r5 r1 1; 183 | loadi r6 r1 1; 184 | loadi r7 r1 1; 185 | storei r25 r2 0; 186 | storei r7 r2 1; 187 | storei r6 r2 2; 188 | storei r5 r2 3; 189 | storei r4 r2 4; 190 | storei r3 r2 5; 191 | storei r39 r2 6; 192 | loadi r39 r1 3; 193 | nop; 194 | storei r39 r2 7; 195 | ret; 196 | addiu r1 r1 4; 197 | /* constants */ 198 | L.1348: .int -1; 199 | L.1343: .float 0.0; 200 | /* Code end */ 201 | -------------------------------------------------------------------------------- /testcodes/arraytest3.ml: -------------------------------------------------------------------------------- 1 | let rec create_float5x3array _ = ( 2 | let vec = create_array 3 0.0 in 3 | let array = create_array 5 vec in 4 | array.(1) <- create_array 3 0.0; 5 | array.(2) <- create_array 3 0.0; 6 | array.(3) <- create_array 3 0.0; 7 | array.(4) <- create_array 3 0.0; 8 | array 9 | ) 10 | in 11 | 12 | let rec create_pixel _ = 13 | let m_rgb = create_array 3 0.0 in 14 | let m_isect_ps = create_float5x3array() in 15 | let m_sids = create_array 5 0 in 16 | let m_cdif = create_array 5 false in 17 | let m_engy = create_float5x3array() in 18 | let m_r20p = create_float5x3array() in 19 | let m_gid = create_array 1 0 in 20 | let m_nvectors = create_float5x3array() in 21 | (m_rgb, m_isect_ps, m_sids, m_cdif, m_engy, m_r20p, m_gid, m_nvectors) 22 | 23 | in 24 | ( 25 | let x = create_pixel() in 26 | let y = create_pixel() in 27 | () 28 | ) 29 | -------------------------------------------------------------------------------- /testcodes/fib.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 20:56:47 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | 10 | entry_point1005: 11 | L.1009: 12 | calli fib_1000; 13 | li r3 10; 14 | put r2; 15 | L.1010: 16 | halt; 17 | jumpi L.1010; 18 | nop; 19 | fib_1000: 20 | subiu r1 r1 2; 21 | L.1011: 22 | bgei r3 2 L.99; 23 | li r2 1; 24 | ret; 25 | addiu r1 r1 2; 26 | L.99: 27 | storei r3 r1 0; 28 | calli fib_1000; 29 | subiu r3 r3 2; 30 | storei r2 r1 1; 31 | loadi r2 r1 0; 32 | calli fib_1000; 33 | subiu r3 r2 1; 34 | loadi r39 r1 1; 35 | nop; 36 | adds r2 r2 r39; 37 | ret; 38 | addiu r1 r1 2; 39 | /* constants */ 40 | /* Code end */ 41 | -------------------------------------------------------------------------------- /testcodes/fib.ml: -------------------------------------------------------------------------------- 1 | let rec fib n = 2 | if n < 2 3 | then 1 4 | else fib (n-1) + fib (n-2) ;; 5 | 6 | 7 | let _ = print_char (fib 10) 8 | -------------------------------------------------------------------------------- /testcodes/float_fib.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 20:56:48 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | loadi r40 r0 L.1011; 10 | loadi r41 r0 L.1014; 11 | loadi r42 r0 L.1015; 12 | 13 | entry_point1005: 14 | L.1010: 15 | move r3 r40; 16 | calli fib_1000; 17 | nop; 18 | ftoi r2 r2; 19 | put r2; 20 | ret; 21 | nop; 22 | L.1012: 23 | halt; 24 | jumpi L.1012; 25 | nop; 26 | fib_1000: 27 | subiu r1 r1 2; 28 | L.1013: 29 | move r11 r41; 30 | bgef r3 r11 L.99; 31 | move r2 r42; 32 | ret; 33 | addiu r1 r1 2; 34 | L.99: 35 | move r9 r41; 36 | storei r3 r1 0; 37 | fsub r3 r3 r9; 38 | calli fib_1000; 39 | nop; 40 | move r6 r42; 41 | storei r2 r1 1; 42 | loadi r2 r1 0; 43 | nop; 44 | fsub r3 r2 r6; 45 | calli fib_1000; 46 | nop; 47 | loadi r39 r1 1; 48 | nop; 49 | fadd r2 r2 r39; 50 | ret; 51 | addiu r1 r1 2; 52 | /* constants */ 53 | L.1011: .float 3.0; 54 | L.1014: .float 2.0; 55 | L.1015: .float 1.0; 56 | /* Code end */ 57 | -------------------------------------------------------------------------------- /testcodes/float_fib.ml: -------------------------------------------------------------------------------- 1 | let rec fib n = 2 | if n < 2.0 3 | then 1.0 4 | else fib (n -. 1.0) +. fib (n -. 2.0) 5 | 6 | let _ = print_char (int_of_float (fib 3.0)) 7 | -------------------------------------------------------------------------------- /testcodes/recur.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 22:15:15 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | 10 | entry_point1014: 11 | L.1016: 12 | li r3 5; 13 | li r4 2; 14 | calli fact_1004; 15 | li r5 1; 16 | calli lib_print_int; 17 | move r3 r2; 18 | ret; 19 | nop; 20 | L.1017: 21 | halt; 22 | jumpi L.1017; 23 | nop; 24 | fact_1000: 25 | L.1018: 26 | ble r5 r3 L.99; 27 | move r2 r4; 28 | ret; 29 | nop; 30 | L.99: 31 | addiu r39 r5 1; 32 | mul r4 r4 r5; 33 | jumpi L.1018; 34 | move r5 r39; 35 | fact_1004: 36 | L.1019: 37 | ble r4 r3 L.99; 38 | move r2 r5; 39 | ret; 40 | nop; 41 | L.99: 42 | mul r5 r5 r4; 43 | jumpi L.1019; 44 | addiu r4 r4 1; 45 | /* constants */ 46 | /* Code end */ 47 | -------------------------------------------------------------------------------- /testcodes/recur.ml: -------------------------------------------------------------------------------- 1 | (* 2 | let rec fact x = 3 | let rec facti i c = 4 | if i > x then c else facti (i + 1) (c * i) in 5 | facti 2 1 in 6 | print_int (fact 5) 7 | *) 8 | 9 | let rec fact x c i = 10 | if i > x then c else fact x (c * i) (i + 1) in 11 | let rec fact x i c = 12 | if i > x then c else fact x (i + 1) (c * i) in 13 | print_int (fact 5 2 1) 14 | -------------------------------------------------------------------------------- /testcodes/tuple_array.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 00:53:34 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | loadi r41 r0 L.1008; 10 | loadi r40 r0 L.1007; 11 | 12 | entry_point1004: 13 | L.1006: 14 | loadi r2 r0 x_1000; 15 | move r8 r40; 16 | li r7 2; 17 | move r9 r41; 18 | nop; 19 | storei r6 r0 x_1000; 20 | storei r5 r0 (x_1000 + 1); 21 | storei r4 r0 (x_1000 + 2); 22 | storei r3 r0 (x_1000 + 3); 23 | put r2; 24 | ret; 25 | nop; 26 | L.1009: 27 | halt; 28 | jumpi L.1009; 29 | nop; 30 | x_1000: 31 | .int 1; 32 | .float 0.0; 33 | .int 1; 34 | .int 0; 35 | .int 1; 36 | .float 0.0; 37 | .int 1; 38 | .int 0; 39 | .int 1; 40 | .float 0.0; 41 | .int 1; 42 | .int 0; 43 | .int 1; 44 | .float 0.0; 45 | .int 1; 46 | .int 0; 47 | .int 1; 48 | .float 0.0; 49 | .int 1; 50 | .int 0; 51 | .int 1; 52 | .float 0.0; 53 | .int 1; 54 | .int 0; 55 | .int 1; 56 | .float 0.0; 57 | .int 1; 58 | .int 0; 59 | .int 1; 60 | .float 0.0; 61 | .int 1; 62 | .int 0; 63 | .int 1; 64 | .float 0.0; 65 | .int 1; 66 | .int 0; 67 | .int 1; 68 | .float 0.0; 69 | .int 1; 70 | .int 0; 71 | /* constants */ 72 | L.1008: .int -1; 73 | L.1007: .float 1.0; 74 | /* Code end */ 75 | -------------------------------------------------------------------------------- /testcodes/tuple_array.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nineties/Choco/0081351d0b556ff74f096accb65c9ab45d29ddfe/testcodes/tuple_array.ml -------------------------------------------------------------------------------- /testcodes/tupletest1.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 20:56:48 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | 10 | entry_point1003: 11 | L.1004: 12 | li r2 1; 13 | put r2; 14 | ret; 15 | nop; 16 | L.1005: 17 | halt; 18 | jumpi L.1005; 19 | nop; 20 | /* constants */ 21 | /* Code end */ 22 | -------------------------------------------------------------------------------- /testcodes/tupletest1.ml: -------------------------------------------------------------------------------- 1 | let x = (1, 2.0, 3) in 2 | let (a, _, _) = x in 3 | print_char a 4 | -------------------------------------------------------------------------------- /testcodes/tupletest2.as: -------------------------------------------------------------------------------- 1 | /* Generated by choco in Mon Jan 21 20:56:48 JST 2008*/ 2 | /* need two nops first */ 3 | nop; 4 | nop; 5 | li r1 768; 6 | slliu r1 r1 4; /* initialize stack pointer */ 7 | move r62 r1; /* initialize heap pointer */ 8 | /* initialize constants */ 9 | 10 | entry_point1011: 11 | L.1012: 12 | li r2 1; 13 | li r4 2; 14 | put r4; 15 | put r2; 16 | ret; 17 | nop; 18 | L.1013: 19 | halt; 20 | jumpi L.1013; 21 | nop; 22 | /* constants */ 23 | /* Code end */ 24 | -------------------------------------------------------------------------------- /testcodes/tupletest2.ml: -------------------------------------------------------------------------------- 1 | let make_tuple a b c = (a, b, c) in 2 | let x = make_tuple 1 2 true in 3 | let y = make_tuple 1.0 3 (1, 2) in 4 | let (_, a, _) = x in 5 | let (_, _, b) = y in 6 | let (c, _) = b in 7 | (print_char a; print_char c) 8 | -------------------------------------------------------------------------------- /tsubaki/Arch.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Arch ( 7 | archName, 8 | sizeAddr, sizeInt, sizeFloat, 9 | AddressingMode(..), 10 | hsramSize 11 | ) where 12 | 13 | archName = "tsubaki" 14 | 15 | sizeAddr, sizeInt, sizeFloat :: Int 16 | sizeAddr = 4 17 | sizeInt = 4 18 | sizeFloat = 4 19 | 20 | data AddressingMode 21 | = Ibased String Int 22 | | Iindexed Int 23 | deriving (Eq, Ord, Show) 24 | 25 | hsramSize :: Int 26 | hsramSize = 128 27 | -------------------------------------------------------------------------------- /tsubaki/Proc.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Proc where 7 | 8 | import Choco 9 | import Mach 10 | import Reg 11 | import RegM 12 | 13 | import Control.Monad.State 14 | import qualified Data.Map as M 15 | 16 | boolRepr True = 1 17 | boolRepr False = -1 18 | 19 | destroyedAtOper :: InstDesc -> ChocoM [Reg] 20 | destroyedAtOper desc = case desc of 21 | Iop Icall_ind -> gets phys_regs 22 | Iop (Icall_imm s) -> do 23 | table <- gets fun_reg_info 24 | case M.lookup s table of 25 | Just regs -> return regs 26 | Nothing -> gets phys_regs 27 | _ -> return [] 28 | 29 | 30 | maxRegisterPressure :: Operation -> Int 31 | maxRegisterPressure op = 24 32 | 33 | safeRegisterPressure :: Operation -> Int 34 | safeRegisterPressure op = 12 35 | 36 | hsramBegin, hsramEnd, numHSRAM :: Int 37 | hsramBegin = 60 38 | hsramEnd = 256 39 | numHSRAM = hsramEnd - hsramBegin 40 | 41 | normalRegFirst = 2 42 | normalRegEnd = 30 43 | numNormalReg = normalRegEnd - normalRegFirst 44 | 45 | globalRegBegin, globalRegEnd, numGlobalReg :: Int 46 | globalRegBegin = normalRegEnd 47 | globalRegEnd = 60 48 | numGlobalReg = globalRegEnd - globalRegBegin 49 | 50 | globalRegs :: ChocoM [Reg] 51 | globalRegs = mapM physReg [globalRegBegin .. globalRegEnd - 1] 52 | 53 | isGlobalReg r = case loc r of 54 | Register n -> globalRegBegin <= n && n < globalRegEnd 55 | _ -> False 56 | 57 | numPhysicalReg :: Int 58 | numPhysicalReg = 64 59 | 60 | physReg n = do 61 | regs <- gets phys_regs 62 | return $ regs !! n 63 | 64 | 65 | stackSlot slot = do 66 | r <- createReg 67 | return $ r{ name = "S", loc = Stack slot } 68 | 69 | callingConventions first last make_stack args 70 | = do 71 | iter first 0 args [] 72 | where 73 | iter _ ofs [] ret = return (reverse ret, ofs) 74 | iter i s (a:as) ret 75 | = if i <= last 76 | then do 77 | r <- physReg i 78 | iter (i+1) s as (r : ret) 79 | else do 80 | r <- stackSlot (make_stack s) 81 | iter i (s+1) as (r : ret) 82 | 83 | locArguments args 84 | = callingConventions 3 (normalRegEnd-1) Outgoing args 85 | 86 | locParameters args 87 | = return.fst =<< callingConventions 3 (normalRegEnd-1) Incoming args 88 | 89 | locResults res 90 | = return.fst =<< callingConventions 2 2 undefined res 91 | 92 | resetRegs :: ChocoM () 93 | resetRegs = do 94 | modify $ \e -> e{ reg_stamp = 0 } 95 | 96 | regs <- mapM (\i -> do 97 | r <- createReg 98 | modifyRegInfo r $ \info -> info{ location = Register i } 99 | return r{ name = "R", loc = Register i } 100 | ) [0 .. numPhysicalReg-1] 101 | 102 | modify $ \e -> e{ 103 | phys_regs = regs, 104 | reg_list = [] 105 | } 106 | 107 | setPrimFunInfo 108 | 109 | reinitRegs :: ChocoM () 110 | reinitRegs = do 111 | reg_list' <- mapM reinit =<< gets reg_list 112 | modify $ \e -> e{ reg_list = reg_list' } 113 | 114 | where 115 | reinit r = do 116 | modifyRegInfo r $ \i -> 117 | i{ location = Unknown, 118 | interf = [], 119 | prefer = [], 120 | degree = 0, 121 | spillCost = if spillCost i >= 100000 then 100000 else 0 122 | } 123 | return r{ loc = Unknown } 124 | {- utilities -} 125 | -- move another source file later 126 | isSignedImm6 n = n <= 31 && n >= -32 127 | isUnsignedImm8 n = n <= 255 && n >= 0 128 | isUnsignedImm10 n = n <= 1023 && n >= 0 129 | isUnsignedImm14 n = n <= 16383 && n >= 0 130 | 131 | updateRegisterLocation fd 132 | = do 133 | m <- gets reg_info_table 134 | let args' = map (set m) (fun_args fd) 135 | i' <- iter m (fun_body fd) 136 | return fd{ fun_args = args', fun_body = i' } 137 | 138 | where 139 | iter m i | idesc i == Iend = return i 140 | iter m i = do 141 | let result' = map (set m) (result i) 142 | let args' = map (set m) (args i) 143 | idesc' <- case idesc i of 144 | Icond test i1 i2 -> do 145 | i1' <- iter m i1 146 | i2' <- iter m i2 147 | return $ Icond test i1' i2' 148 | _ -> return (idesc i) 149 | 150 | next' <- iter m (next i) 151 | return i{ result = result', args = args', idesc = idesc', next = next' } 152 | 153 | set table reg = reg{ loc = location $ table M.! reg } 154 | 155 | -- move this table another place 156 | setPrimFunInfo :: ChocoM () 157 | setPrimFunInfo = do 158 | mapM_ (\(name, nums) -> do 159 | regs <- mapM physReg nums 160 | modify $ \e -> e{ fun_reg_info = M.insert name regs (fun_reg_info e) } 161 | ) [("lib_read", [2,3,4]), 162 | ("lib_create_array", [2,3,4,5]), 163 | ("lib_int_of_float", [2,3,4,5,6,7]), 164 | ("lib_float_of_int", [2,3,4,5,6]), 165 | ("lib_floor", [2,3,4,5,6,7]), 166 | ("lib_sin", [2,3,4,5,6,7]), 167 | ("lib_cos", [2,3,4,5,6,7]), 168 | ("lib_atan",[2,3,4,5,6,7,8,9,10])] 169 | -------------------------------------------------------------------------------- /tsubaki/Scheduling.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------- 2 | -- Choco -- 3 | -- Chikadzume Oriented Compiler -- 4 | -- Copyright 2007-2008 by Basement fairy -- 5 | ------------------------------------------------- 6 | module Scheduling ( 7 | opLatency, 8 | opIssueCycles, 9 | opInBasicBlock 10 | ) where 11 | 12 | import Mach hiding (Inst(..)) 13 | 14 | import qualified Data.IntMap as I 15 | import qualified Data.Map as M 16 | import qualified Control.Monad.State as ST 17 | import Control.Monad 18 | 19 | {- instruction informations -} 20 | opLatency op = case op of 21 | Ireload -> 2 22 | Iload _ -> 2 23 | Istore _ -> 2 24 | Iconst_float _ -> 2 25 | Iput -> 2 26 | Iget -> 2 27 | _ | op `elem` [Isqrt, Ifinv, Ifadd, Ifsub, Ifmul] 28 | -> 3 29 | _ -> 1 30 | 31 | opIssueCycles op = case op of 32 | Iconst_float _ -> 2 33 | Iconst_symbol _ -> 2 34 | _ -> 1 35 | 36 | opInBasicBlock op = case op of 37 | Icall_ind -> False 38 | Icall_imm _ -> False 39 | Itailcall_ind -> False 40 | Itailcall_imm _ -> False 41 | _ -> True 42 | --------------------------------------------------------------------------------