@@ -17,6 +17,7 @@ import System.Process
1717import System.IO
1818import System.Directory
1919import System.Environment
20+import Debug.Trace
2021
2122import Paths_idris
2223
@@ -72,18 +73,19 @@ codegenC :: Name -> Int -> PreC -> String
7273codegenC n args prec
7374 = "/* " ++ show prec ++ " */\n\n" ++
7475 "void " ++ cname n ++ "(VM* vm) {\n" ++
76+ indent 1 ++ "int i;\n" ++
7577 concatMap (cg 1) prec ++ "}\n\n"
7678
7779indent i = take (i * 4) (repeat ' ')
7880
7981reg RVal = "vm->ret"
80−reg (LVar v) = "*(vm->stack-" ++ show v ++ ")"
82+reg (LVar v) = "*(vm->valstack_ptr-" ++ show v ++ ")"
8183
8284catom :: CAtom -> String
8385catom (CL l) = reg (LVar l)
8486catom (CC (I i)) = "MKINT(" ++ show i ++ ")"
8587catom (CC v) = "const(" ++ show v ++ ")"
86−catom (CP n) = cname n
88+catom (CP n i) = "MKCLOSURE(" ++ cname n ++ ", " ++ show i ++ ")"
8789
8890off o (CL i) = CL (i + o)
8991off o x = x
@@ -111,6 +113,22 @@ assignFn i r f args
111113 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "
112114 ++ setArgs (i + 1) as
113115
116+assignClosure i lazy r atom args
117+ = indent i ++ reg r ++ " = APPLY(" ++ catom atom ++ ", " ++ show (length args) ++
118+ ");\n" ++
119+ indent i ++ setArgs 0 args ++ "\n" ++
120+ if not lazy then
121+ indent i ++ "if (READY(" ++ reg r ++ ")) {\n" ++
122+ indent (i + 1) ++ reg r ++ " = EVAL(" ++ reg r ++ ");\n" ++
123+ indent i ++ "} else {\n" ++
124+ indent (i + 1) ++ "// do nothing \n" ++
125+ indent i ++ "}\n"
126+ else ""
127+ where
128+ setArgs i [] = ""
129+ setArgs i (a : as) = "ADDARG(" ++ show i ++ ", " ++ reg r ++ ", " ++ catom a ++ "); "
130+ ++ setArgs (i + 1) as
131+
114132doTailCall i d f args
115133 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++
116134 indent i ++ setArgs 1 (map (off (length args)) (reverse args)) ++ "\n" ++
@@ -121,11 +139,36 @@ doTailCall i d f args
121139 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "
122140 ++ setArgs (i + 1) as
123141
142+assignFCall i r cfn rt args
143+ = indent i ++ reg r ++ " = " ++ fromC rt ++
144+ "(" ++
145+ cfn ++ "(" ++ showSep ", " (map toCa args) ++ "))" ++ ";\n"
146+ where fromC (Just IType) = "MKINT"
147+ fromC (Just StrType) = "MKSTR"
148+ fromC _ = "MKVAL"
149+
150+ toC (Just IType) = "GETINT"
151+ toC (Just StrType) = "GETSTR"
152+ toC _ = "GETVAL"
153+
154+ toCa (a, ty) = toC ty ++ "(" ++ catom a ++ ")"
155+
156+assignPrimOp i r p args
157+ = indent i ++ reg r ++ " = " ++ op p args ++ ";\n"
158+
124159cg :: Int -> CInst -> String
125160cg i (ASSIGN r (CCon t args))
126161 = assignCon i r t args
127162cg i (ASSIGN r (CExactApp f args))
128163 = assignFn i r f args
164+cg i (ASSIGN r (CApp f args))
165+ = assignClosure i False r f args
166+cg i (ASSIGN r (CLazy f args))
167+ = assignClosure i True r f args
168+cg i (ASSIGN r (CFCall cfn rt args))
169+ = assignFCall i r cfn rt args
170+cg i (ASSIGN r (CPrimOp p args))
171+ = assignPrimOp i r p args
129172cg i (ASSIGN r (CAtom e)) = indent i ++ reg r ++ " = " ++ catom e ++ ";\n"
130173cg i (RESERVE s) = indent i ++ "EXTEND(" ++ show s ++ ");\n"
131174cg i (CLEAR s) = indent i ++ "CLEAR(" ++ show s ++ ");\n"
@@ -145,9 +188,10 @@ cg i (SWITCH v bs def)
145188 branch (t, c) = indent i ++ "case " ++ show t ++ ":\n" ++
146189 concatMap (cg (i+1)) c ++
147190 indent (i+1) ++ "break;\n"
191+cg i (TAILCALL d f args) = assignClosure i False RVal f args -- doTailClosure i d f args
148192cg i (TAILCALLEXACT d f args) = doTailCall i d f args
149193cg i (ERROR s) = indent i ++ "ERROR(" ++ show s ++ ")\n";
150−cg i _ = indent i ++ "NOT DONE;\n"
194+cg i x = trace (show x ++ " not done") $ indent i ++ "NOT DONE;\n"
151195
152196cname :: Name -> String
153197cname (UN s) = "_I_" ++ toC s
@@ -162,3 +206,13 @@ toC s = concatMap special s
162206proto :: Name -> String
163207proto n = "void " ++ cname n ++ "(VM* vm);\n"
164208
209+op AddI [l, r] = "INTOP(+, " ++ catom l ++ ", " ++ catom r ++ ")"
210+op SubI [l, r] = "INTOP(-, " ++ catom l ++ ", " ++ catom r ++ ")"
211+op MulI [l, r] = "INTOP(*, " ++ catom l ++ ", " ++ catom r ++ ")"
212+op DivI [l, r] = "INTOP(/, " ++ catom l ++ ", " ++ catom r ++ ")"
213+
214+op ConcatS [l,r] = "CONCAT(" ++ catom l ++ ", " ++ catom r ++ ")"
215+
216+op o args = trace (show (op, args) ++ " operator undefined")
217+ $ "0 /* Op not defined " ++ show o ++ " */"
218+