Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 183 lines (144 sloc) 5.616 kb
e520a0c Pawel Murias [hoopl]
pmurias authored
1 {-# LANGUAGE ViewPatterns,GADTs,StandaloneDeriving,NoMonomorphismRestriction #-}
2 module Nam where
3 import Data.Aeson;
4 import Data.Attoparsec.Number
5 import Control.Monad
6 import Debug.Trace
7 import Data.Vector ((!))
8 import Compiler.Hoopl
9 import qualified Op
10 import qualified Data.Text as T
11 import qualified Data.Vector as V
12 import Control.Monad.State.Strict
b210553 Pawel Murias [hoopl] added a constant propagation pass which does nothing but
pmurias authored
13 import Insn
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
14 import Util
e520a0c Pawel Murias [hoopl]
pmurias authored
15
16
17 instance NonLocal (Insn)
18
19
20
21
22 freshId = do
23 id <- get
24 put (id+1)
25 return $ id
26
27 simple val = return $ (emptyGraph,val)
28
29 convert :: Op.Op -> State Int ((Graph Insn O O),Expr)
30
31 -- ops which map directly to Expr
32
33 convert (Op.Double d) = simple $ Double d
34 convert (Op.StrLit str) = simple $ StrLit str
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
35 convert (Op.ScopedLex str) = simple $ ScopedLex str
e520a0c Pawel Murias [hoopl]
pmurias authored
36
37 -- HACKS
38
39 convert (Op.Ann _ op) = convert op
40 convert (Op.Box _ op) = convert op
41 convert (Op.Const op) = convert op
42
43
44 convert (Op.Prog ops) = do
45 converted <- mapM convert ops
46 let (setup,vals) = unzip converted
47 return $ (foldl1 (<*>) setup,last vals)
48
49 convert (Op.Subcall args) = do
50 converted <- mapM convert args
51 let (setup,vals) = unzip converted
52 id <- freshId
53 return $ (((foldl1 (<*>) setup) <*> (mkMiddle $ Subcall id vals)),Reg id)
54
55 convert (Op.Fetch arg) = do
56 id <- freshId
57 (setup,val) <- convert arg
58 return $ (setup <*> (mkMiddle $ Fetch id val),Reg id)
59
e1d1478 Pawel Murias [hoopl] support bif_plus
pmurias authored
60 convert (Op.BifPlus a b) = do
61 id <- freshId
62 (setup1,val1) <- convert a
63 (setup2,val2) <- convert b
64 return $ (setup1 <*> setup2 <*> (mkMiddle $ BifPlus id val1 val2),Reg id)
65
79da9b6 Pawel Murias [hoopl] constant folding for bif_minus and bif_divide
pmurias authored
66 convert (Op.BifDivide a b) = do
67 id <- freshId
68 (setup1,val1) <- convert a
69 (setup2,val2) <- convert b
70 return $ (setup1 <*> setup2 <*> (mkMiddle $ BifDivide id val1 val2),Reg id)
71
72 convert (Op.BifMinus a b) = do
73 id <- freshId
74 (setup1,val1) <- convert a
75 (setup2,val2) <- convert b
76 return $ (setup1 <*> setup2 <*> (mkMiddle $ BifMinus id val1 val2),Reg id)
77
e609afb Pawel Murias [hoopl] handle sink - not sure if ignoring it is always correct
pmurias authored
78 convert (Op.Sink arg) = convert arg
79
e520a0c Pawel Murias [hoopl]
pmurias authored
80 -- HACK those nodes shouldn't be ignored
81
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
82 convert (Op.Unknown value) = error $ "Can't convert: " ++ (toStr value)
e520a0c Pawel Murias [hoopl]
pmurias authored
83 convert (other) = error $ "Can't convert: " ++ (show other)
84
85 --convert (expr) = do
86 -- (setup,val) <- convertToExpr expr
87 -- return setup
88
89 data Xref = Xref {
90 unit :: String, -- Names unit of origin
91 index :: Integer, -- Indexes into unit's xref array
92 xref_name :: String -- Descriptive name for debugging
93 } deriving Show
94
95 data Unit = Unit {
96 mainline_ref :: Xref, -- Xref to mainline subroutine
97 name :: String, -- Unit's unique name
98 -- log :: ... -- Mostly unused vestige of last stash system
99 setting :: String, -- Name of setting unit or null
100 bottom_ref :: Maybe Xref, -- Xref to sub containing {YOU_ARE_HERE}, or null
101 filename :: String, -- Filename of source code or null
102 modtime :: Integer, -- Seconds since 1970-01-01
103 xref :: [XrefThing] -- Resolves refs from other units
104 -- tdeps :: TDep -- Holds dependency data for recompilation
105 -- stash_root :: StNode -- Trie holding classes and global variables
106 } deriving Show
107
108
109 {-
110 data Sub =
111 name string Sub's name for backtraces
112 outer_xref Xref OUTER:: sub, may be in a setting unit
113 flags number [1]
114 children num[] Supports tree traversals
115 param_role_hack ... [2]
116 augment_hack ... [3]
117 hint_hack ... [4]
118 is_phaser number [5]
119 body_of Xref Only valid in immediate block of class {} et al
120 in_class Xref Innermost enclosing body_of
121 cur_pkg str[] OUR:: as a list of names
122 class string &?BLOCK.WHAT; "Sub" or "Regex"
123 ltm LtmNode Only for regexes; stores declarative prefix
124 exports str[][] List of global names
125 signature Param[] May be null in exotic cases
126 lexicals Lex[] Come in multiple forms
127 nam ... See description of opcodes earlier-}
128
129 data XrefThing = Sub {
130 subName :: String,
131 nam :: Op.Op
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
132 } | Missing | Other String
e520a0c Pawel Murias [hoopl]
pmurias authored
133 deriving Show
134
135 parseXrefThing "sub" a = do
136 subName_ <- parseJSON (a ! 1)
137 return $ Sub {subName=subName_,nam=Op.rawOpsToOp (a ! 17)}
138
139 parseXrefThing thing_type _ = return $ Other thing_type
140
141 instance FromJSON XrefThing where
142 parseJSON (Array a) = do
143 thing_type <- parseJSON (a ! 0)
144 parseXrefThing thing_type a
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
145 parseJSON Null = return $ Missing
146 parseJSON other = fail ("Can't parse XrefThing:"++(show other))
e520a0c Pawel Murias [hoopl]
pmurias authored
147
148
149 instance FromJSON Xref where
150 parseJSON (Array a) = do
151 unit <- parseJSON (a ! 0)
152 index <- parseJSON (a ! 1)
153 xref_name <- parseJSON (a ! 2)
154 return $ Xref { unit=unit, index=index, xref_name=xref_name }
155
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
156 parseJSON other = fail ("Can't parse Xref:"++(show other))
157
e520a0c Pawel Murias [hoopl]
pmurias authored
158
159 instance FromJSON Unit where
160 parseJSON (Array a) = do
161 mainline_ref <- parseJSON (a ! 0)
162 name <- parseJSON (a ! 1)
163 -- skipping log and setting
164 --
165 setting <- parseJSON (a ! 3)
166 bottom_ref <- parseJSON (a ! 4)
167 filename <- parseJSON (a ! 5)
168 modtime <- parseJSON (a ! 6)
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
169 xref <- trace (toStr $ a ! 7) $ parseJSON (a ! 7)
e520a0c Pawel Murias [hoopl]
pmurias authored
170 return $ Unit {
171 mainline_ref=mainline_ref,
172 name=name,
173 setting=setting,
174 bottom_ref=bottom_ref,
175 filename=filename,
176 modtime=modtime,
177 xref=xref
178 }
4db171f Pawel Murias [hoopl] simple-test/if.t is converted to Op
pmurias authored
179 parseJSON other = fail ("Can't parse Unit:"++(show other))
e520a0c Pawel Murias [hoopl]
pmurias authored
180
181
182 --showNode x = "...;\n"
Something went wrong with that request. Please try again.