61 fun Val v s = "val " ^ v ^ " = " ^ s; |
64 fun Val v s = "val " ^ v ^ " = " ^ s; |
62 fun Let ds e = "let\n" ^ (space_implode "\n" ds) ^ " in " ^ e ^ " end" |
65 fun Let ds e = "let\n" ^ (space_implode "\n" ds) ^ " in " ^ e ^ " end" |
63 |
66 |
64 end |
67 end |
65 |
68 |
66 val tab_lookup = S.app "NormByEval.lookup"; |
69 val tab_lookup = S.app "NBE.lookup"; |
67 val tab_update = S.app "NormByEval.update"; |
70 val tab_update = S.app "NBE.update"; |
68 |
71 |
69 fun mk_nbeFUN(nm,e) = |
72 fun mk_nbeFUN(nm,e) = |
70 S.app Eval_Fun (S.tup [S.abs(S.list [MLvname nm])e,S.list [],"1", |
73 S.app Eval_Fun (S.tup [S.abs(S.list [MLvname nm])e,S.list [],"1", |
71 S.abs(S.tup [])(S.Let |
74 S.abs(S.tup [])(S.Let |
72 [S.Val (MLintern "var") (S.app Eval_new_name (S.tup [])), |
75 [S.Val (MLintern "var") (S.app Eval_new_name (S.tup [])), |
115 in mk [] end; |
118 in mk [] end; |
116 |
119 |
117 fun mk_eqn defined nm ar (lhs,e) = |
120 fun mk_eqn defined nm ar (lhs,e) = |
118 ([S.list(map mk_lexpr (rev lhs))], mk_rexpr defined nm ar e); |
121 ([S.list(map mk_lexpr (rev lhs))], mk_rexpr defined nm ar e); |
119 |
122 |
120 fun funs_of_expr (IConst ((s, _), _)) = insert (op =) s |
123 fun consts_of (IConst ((s, _), _)) = insert (op =) s |
121 | funs_of_expr (e1 `$ e2) = |
124 | consts_of (e1 `$ e2) = |
122 funs_of_expr e1 #> funs_of_expr e2 |
125 consts_of e1 #> consts_of e2 |
123 | funs_of_expr (_ `|-> e) = funs_of_expr e |
126 | consts_of (_ `|-> e) = consts_of e |
124 | funs_of_expr (IAbs (_, e)) = funs_of_expr e |
127 | consts_of (IAbs (_, e)) = consts_of e |
125 | funs_of_expr (ICase (_, e)) = funs_of_expr e |
128 | consts_of (ICase (_, e)) = consts_of e |
126 | funs_of_expr _ = I; |
129 | consts_of _ = I; |
127 |
130 |
128 fun lookup nm = S.Val (MLname nm) (tab_lookup (S.quote nm)); |
131 fun lookup nm = S.Val (MLname nm) (tab_lookup (S.quote nm)); |
129 |
132 |
130 fun generate defined (nm, CodegenThingol.Fun (eqns, _)) = |
133 fun generate defined (nm, CodegenThingol.Fun (eqns, _)) = |
|
134 let |
|
135 val ar = length(fst(hd eqns)); |
|
136 val params = S.list (rev (MLparams ar)); |
|
137 val funs = Library.flat(map (fn (_,e) => consts_of e []) eqns) \ nm; |
|
138 val globals = map lookup (filter defined funs); |
|
139 val default_eqn = ([params], S.app Eval_Constr (S.tup[S.quote nm,params])); |
|
140 val code = S.eqns (MLname nm) |
|
141 (map (mk_eqn defined nm ar) eqns @ [default_eqn]) |
|
142 val register = tab_update |
|
143 (S.app Eval_mk_Fun (S.tup[S.quote nm, MLname nm, string_of_int ar])) |
|
144 in |
|
145 S.Let (globals @ [code]) register |
|
146 end |
|
147 | generate _ _ = ""; |
|
148 |
|
149 open NBE_Eval; |
|
150 |
|
151 fun nterm_to_term thy t = |
131 let |
152 let |
132 val ar = length(fst(hd eqns)); |
153 fun consts_of (C s) = insert (op =) s |
133 val params = S.list (rev (MLparams ar)); |
154 | consts_of (V _) = I |
134 val funs = Library.flat(map (fn (_,e) => funs_of_expr e []) eqns) \ nm; |
155 | consts_of (B _) = I |
135 val globals = map lookup (filter defined funs); |
156 | consts_of (A (t1, t2)) = consts_of t1 #> consts_of t2 |
136 val default_eqn = ([params], S.app Eval_Constr (S.tup[S.quote nm,params])); |
157 | consts_of (AbsN (_, t)) = consts_of t; |
137 val code = S.eqns (MLname nm) |
158 val consts = consts_of t []; |
138 (map (mk_eqn defined nm ar) eqns @ [default_eqn]) |
159 val the_const = AList.lookup (op =) |
139 val register = tab_update |
160 (consts ~~ CodegenPackage.consts_of_idfs thy consts) |
140 (S.app Eval_mk_Fun (S.tup[S.quote nm, MLname nm, string_of_int ar])) |
161 #> the_default ("", dummyT); |
141 in |
162 fun to_term bounds (C s) = Const (the_const s) |
142 S.Let (globals @ [code]) register |
163 | to_term bounds (V s) = Free (s, dummyT) |
143 end |
164 | to_term bounds (B i) = Bound (find_index (fn j => i = j) bounds) |
144 | generate _ _ = ""; |
165 | to_term bounds (A (t1, t2)) = to_term bounds t1 $ to_term bounds t2 |
|
166 | to_term bounds (AbsN (i, t)) = |
|
167 Abs("u", dummyT, to_term (i::bounds) t); |
|
168 in to_term [] t end; |
145 |
169 |
146 end; |
170 end; |
147 |
171 |
148 (* |
172 (* |
149 |
173 |