f7f8d92 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Tail calls via trampolines in C back end

This means we can turn off the clang optimiser and still have working code generated. It does mean that the code generated is a bit slower (there's a small overhead for the trampolines) but it compiles much faster, which is a big deal for developing larger systems! We need a way to turn the clang optimiser back on - probably just a compiler flag.

commitf7f8d923353b5ff20ece7a62a6169ab7b3ac6831 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateThu 21 Jun 2018, 20:17 (8 years ago) parent375d62f

4 files changed+85−72

compare with master

unifiedsplit

rts/idris_main.c+1−1 rts/idris_rts.h+10−5 src/IRTS/CodegenC.hs+56−57 src/IRTS/LangOpts.hs+18−9

rts/idris_main.c+1−1

@@ -3,7 +3,7 @@

33#include "idris_rts.h"

44#include "idris_stats.h"

6−void _idris__123_runMain_95_0_125_(VM* vm, VAL* oldbase);

6+void* _idris__123_runMain_95_0_125_(VM* vm, VAL* oldbase);

88#ifdef _WIN32

rts/idris_rts.h+10−5

@@ -212,7 +212,7 @@ void init_threadkeys(void);

212212

213213// Functions all take a pointer to their VM, and previous stack base,

214214// and return nothing.

215−typedef void(*func)(VM*, VAL*);

215+typedef void*(*func)(VM*, VAL*);

216216

217217// Register access

218218

@@ -282,9 +282,10 @@ typedef intptr_t i_int;

282282#endif

283283

284284#define INITFRAME TRACE\

285− __attribute__((unused)) VAL* myoldbase

285+ __attribute__((unused)) VAL* myoldbase;\

286+ void* callres

286287

287−#define REBASE vm->valstack_base = oldbase

288+#define REBASE vm->valstack_base = oldbase; return NULL

288289#define RESERVE(x) do { \

289290 if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \

290291 else { memset(vm->valstack_top, 0, (x)*sizeof(VAL)); } \

@@ -293,8 +294,12 @@ typedef intptr_t i_int;

293294#define TOPBASE(x) vm->valstack_top = vm->valstack_base + (x)

294295#define BASETOP(x) vm->valstack_base = vm->valstack_top + (x)

295296#define STOREOLD myoldbase = vm->valstack_base

296−#define CALL(f) f(vm, myoldbase);

297−#define TAILCALL(f) f(vm, oldbase);

297+

298+#define CALL(f) callres = f(vm, myoldbase); \

299+ while(callres!=NULL) { \

300+ callres = ((func)(callres))(vm, myoldbase); \

301+ }

302+#define TAILCALL(f) return (void*)(f);

298303

299304// Creating new values (each value placed at the top of the stack)

300305VAL MKFLOAT(VM* vm, double val);

src/IRTS/CodegenC.hs+56−57

@@ -117,11 +117,7 @@ gccFlags i = if i then ["-fwrapv"]

117117 else ["-fwrapv", "-fno-strict-overflow"]

118118

119119gccDbg DEBUG = ["-g"]

120−-- clang optimises sibling calls in O1, but gcc doesn't

121−-- on the other hand, O1 compiles significantly faster in clang without

122−-- any noticeable performance hit.

123−gccDbg TRACE = ["-O1", "-foptimize-sibling-calls"]

124−gccDbg _ = ["-O1", "-foptimize-sibling-calls"]

120+gccDbg _ = []

125121

126122cname :: Name -> String

127123cname n = "_idris_" ++ concatMap cchar (showCG n)

@@ -137,14 +133,14 @@ creg (T i) = "TOP(" ++ show i ++ ")"

137133creg Tmp = "REG1"

138134

139135toDecl :: Name -> String

140−toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"

136+toDecl f = "void* " ++ cname f ++ "(VM*, VAL*);\n"

141137

142138toC :: Name -> [BC] -> String

143139toC f code

144140 = -- "/* " ++ show code ++ "*/\n\n" ++

145− "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++

146− indent 1 ++ "INITFRAME;\n" ++

147− concatMap (bcc 1) code ++ "}\n\n"

141+ "void* " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++

142+ indent 1 ++ "INITFRAME;\nloop:\n" ++

143+ concatMap (bcc f 1) code ++ "}\n\n"

148144

149145showCStr :: String -> String

150146showCStr s = '"' : foldr ((++) . showChar) "\"" s

@@ -180,9 +176,9 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s

180176 2 -> s

181177 _ -> error $ "Can't happen: String of invalid length " ++ show s

182178

183−bcc :: Int -> BC -> String

184−bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

185−bcc i (ASSIGNCONST l c)

179+bcc :: Name -> Int -> BC -> String

180+bcc f i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

181+bcc f i (ASSIGNCONST l c)

186182 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"

187183 where

188184 mkConst (I i) = "MKINT(" ++ show i ++ ")"

@@ -203,10 +199,10 @@ bcc i (ASSIGNCONST l c)

203199 mkConst c | isTypeConst c = "MKINT(42424242)"

204200 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

205201

206−bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

207−bcc i (MKCON l loc tag []) | tag < 256

202+bcc f i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

203+bcc f i (MKCON l loc tag []) | tag < 256

208204 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"

209−bcc i (MKCON l loc tag args)

205+bcc f i (MKCON l loc tag args)

210206 = indent i ++ alloc loc tag ++

211207 indent i ++ setArgs 0 args ++ "\n" ++

212208 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

@@ -220,21 +216,21 @@ bcc i (MKCON l loc tag args)

220216 = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " ++

221217 show (length args) ++ ");\n"

222218

223−bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

219+bcc f i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

224220 ", " ++ show a ++ ");\n"

225−bcc i (PROJECTINTO r t idx)

221+bcc f i (PROJECTINTO r t idx)

226222 = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

227−bcc i (CASE True r [(_, alt)] Nothing)

223+bcc f i (CASE True r [(_, alt)] Nothing)

228224 = indent i ++ showCode i alt

229225 where

230226 showCode :: Int -> [BC] -> String

231− showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++

227+ showCode i bc = "{\n" ++ concatMap (bcc f (i + 1)) bc ++

232228 indent i ++ "}\n"

233−bcc i (CASE True r code def)

229+bcc f i (CASE True r code def)

234230 | length code < 6 && length code > 1 = showCase i def code

235231 where

236232 showCode :: Int -> [BC] -> String

237− showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++

233+ showCode i bc = "{\n" ++ concatMap (bcc f (i + 1)) bc ++

238234 indent i ++ "}\n"

239235

240236 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

@@ -244,7 +240,7 @@ bcc i (CASE True r code def)

244240 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

245241 ++ indent i ++ "else\n" ++ showCase i def cs

246242

247−bcc i (CASE safe r code def)

243+bcc f i (CASE safe r code def)

248244 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

249245 concatMap (showCase i) code ++

250246 showDef i def ++

@@ -254,11 +250,12 @@ bcc i (CASE safe r code def)

254250 ctag False = "TAG"

255251

256252 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

257− ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"

258− showDef i Nothing = ""

253+ ++ concatMap (bcc f (i+1)) bc ++ indent (i + 1) ++ "break;\n"

254+ showDef i Nothing = indent i ++ "default:\n" ++

255+ indent (i + 1) ++ "return NULL;\n"

259256 showDef i (Just c) = indent i ++ "default:\n"

260− ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"

261−bcc i (CONSTCASE r code def)

257+ ++ concatMap (bcc f (i+1)) c ++ indent (i + 1) ++ "break;\n"

258+bcc f i (CONSTCASE r code def)

262259 | intConsts code

263260-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++

264261-- concatMap (showCase i) code ++

@@ -290,65 +287,67 @@ bcc i (CONSTCASE r code def)

290287

291288 strCase sv (s, bc) =

292289 indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" ++

293− concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

290+ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

294291 biCase bv (BI b, bc) =

295292 indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"

296− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

293+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

297294 iCase v (I b, bc) =

298295 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"

299− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

296+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

300297 iCase v (Ch b, bc) =

301298 indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show (fromEnum b) ++ ") {\n"

302− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

299+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

303300 iCase v (B8 w, bc) =

304301 indent i ++ "if (GETBITS8(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"

305− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

302+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

306303 iCase v (B16 w, bc) =

307304 indent i ++ "if (GETBITS16(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"

308− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

305+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

309306 iCase v (B32 w, bc) =

310307 indent i ++ "if (GETBITS32(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"

311− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

308+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

312309 iCase v (B64 w, bc) =

313310 indent i ++ "if (GETBITS64(" ++ v ++ ") == " ++ show (fromEnum w) ++ ") {\n"

314− ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

311+ ++ concatMap (bcc f (i+1)) bc ++ indent i ++ "} else\n"

315312 showDefS i Nothing = ""

316− showDefS i (Just c) = concatMap (bcc (i+1)) c

317−

318−bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"

319−bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"

320−bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"

321−bcc i REBASE = indent i ++ "REBASE;\n"

322−bcc i (RESERVE 0) = ""

323−bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"

324−bcc i (ADDTOP 0) = ""

325−bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"

326−bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

327−bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

328−bcc i STOREOLD = indent i ++ "STOREOLD;\n"

329−bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

330−bcc i (FOREIGNCALL l rty (FStr ('#':name)) [])

313+ showDefS i (Just c) = concatMap (bcc f (i+1)) c

314+

315+bcc f i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n"

316+bcc f i (TAILCALL n)

317+ | f == n = indent i ++ "goto loop;\n"

318+ | otherwise = indent i ++ "TAILCALL(" ++ cname n ++ ");\n"

319+bcc f i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n"

320+bcc f i REBASE = indent i ++ "REBASE;\n"

321+bcc f i (RESERVE 0) = ""

322+bcc f i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"

323+bcc f i (ADDTOP 0) = ""

324+bcc f i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n"

325+bcc f i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

326+bcc f i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

327+bcc f i STOREOLD = indent i ++ "STOREOLD;\n"

328+bcc f i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

329+bcc f i (FOREIGNCALL l rty (FStr ('#':name)) [])

331330 = indent i ++

332331 c_irts (toFType rty) (creg l ++ " = ") name ++ ";\n"

333−bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])

332+bcc f i (FOREIGNCALL l rty (FStr fn@('&':name)) [])

334333 = indent i ++

335334 c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"

336−bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"

335+bcc f i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"

337336 = indent i ++

338337 c_irts (toFType rty) (creg l ++ " = ")

339338 ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"

340−bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"

339+bcc f i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"

341340 = indent i ++ c_irts (toFType rty) (creg l ++ " = ")

342341 ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++

343342 "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"

344−bcc i (FOREIGNCALL l rty (FStr fn) args)

343+bcc f i (FOREIGNCALL l rty (FStr fn) args)

345344 = indent i ++

346345 c_irts (toFType rty) (creg l ++ " = ")

347346 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

348−bcc i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."

349−bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

350−bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

351−-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

347+bcc f i (FOREIGNCALL l rty _ args) = error "Foreign Function calls cannot be partially applied, without being inlined."

348+bcc f i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

349+bcc f i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

350+-- bcc f i c = error (show c) -- indent i ++ "// not done yet\n"

352351

353352fcall (t, arg) = irts_c (toFType t) (creg arg)

354353-- Deconstruct the Foreign type in the defunctionalised expression and build

src/IRTS/LangOpts.hs+18−9

@@ -113,6 +113,8 @@ eval stk env rec defs (LProj exp i)

113113 = unload stk <$> (LProj <$> eval [] env rec defs exp <*> return i)

114114eval stk env rec defs (LCon loc i n es)

115115 = unload stk <$> (LCon loc i n <$> mapM (eval [] env rec defs) es)

116+eval stk env rec defs (LCase ty e [])

117+ = pure LNothing

116118eval stk env rec defs (LCase ty e alts)

117119 = do e' <- eval [] env rec defs e

118120 case evalAlts e' alts of

@@ -184,19 +186,24 @@ apply stk env rec defs var args body

184186 = eval stk env rec defs (LLam args body)

185187

186188dropArgs :: [Name] -> LAlt -> State Int LAlt

187−dropArgs as (LConCase i n es (LLam args rhs))

188− = do let old = take (length as) args

189− rhs' <- eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs

189+dropArgs as (LConCase i n es t)

190+ = do rhs' <- dropArgsTm as t

190191 return (LConCase i n es rhs')

191−dropArgs as (LConstCase c (LLam args rhs))

192− = do let old = take (length as) args

193− rhs' <- eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs

192+dropArgs as (LConstCase c t)

193+ = do rhs' <- dropArgsTm as t

194194 return (LConstCase c rhs')

195−dropArgs as (LDefaultCase (LLam args rhs))

196− = do let old = take (length as) args

197− rhs' <- eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs

195+dropArgs as (LDefaultCase t)

196+ = do rhs' <- dropArgsTm as t

198197 return (LDefaultCase rhs')

199198

199+dropArgsTm as (LLam args rhs)

200+ = do let old = take (length as) args

201+ eval [] (zipWith (\ o n -> (o, LV n)) old as) [] emptyContext rhs

202+dropArgsTm as (LLet n val rhs)

203+ = do rhs' <- dropArgsTm as rhs

204+ pure (LLet n val rhs')

205+dropArgsTm as tm = return tm

206+

200207caseFloat :: LExp -> LExp

201208caseFloat (LApp tc e es) = LApp tc (caseFloat e) (map caseFloat es)

202209caseFloat (LLazyExp e) = LLazyExp (caseFloat e)

@@ -292,12 +299,14 @@ getRHS (LDefaultCase rhs) = rhs

292299

293300getLams [] = []

294301getLams (LLam args tm : cs) = getLamPrefix args cs

302+getLams (LLet n val exp : cs) = getLams (exp : cs)

295303getLams _ = []

296304

297305getLamPrefix as [] = as

298306getLamPrefix as (LLam args tm : cs)

299307 | length args < length as = getLamPrefix args cs

300308 | otherwise = getLamPrefix as cs

309+getLamPrefix as (LLet n val exp : cs) = getLamPrefix as (exp : cs)

301310getLamPrefix as (_ : cs) = []

302311

303312-- eta contract ('\x -> f x' can just be compiled as 'f' when f is local)