2fc1fc6 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Implement a RWS monad for the C backend

2fc1fc6Niklas Larsson11 years ago

src/IRTS/CodegenC.hs+234−116

compare with master

unifiedsplit

@@ -7,7 +7,7 @@ Maintainer : The Idris Community.

7-}

8module IRTS.CodegenC (codegenC) where

10−import Idris.AbsSyntax

10+import Idris.AbsSyntax hiding (getBC)

11import Idris.Core.TT

12import IRTS.Bytecode

13import IRTS.CodegenCommon

@@ -21,14 +21,19 @@ import Util.System

21import Control.Monad

22import Data.Bits

23import Data.Char

24−import Data.List (intercalate, nubBy)

25−import Debug.Trace

26import Numeric

24import Numeric

27−import System.Directory

25+import Data.List (find, intercalate, nubBy, partition)

26+import qualified Data.Text as T

28import System.Exit

27import System.Exit

29import System.FilePath ((<.>), (</>))

28import System.FilePath ((<.>), (</>))

30import System.IO

29import System.IO

31import System.Process

30import System.Process

31+import System.Directory

32+import System.FilePath ((</>), (<.>))

33+import Control.Monad

34+import Control.Monad.RWS

35+

36+import Debug.Trace

33codegenC :: CodeGenerator

38codegenC :: CodeGenerator

34codegenC ci = do codegenC' (simpleDecls ci)

39codegenC ci = do codegenC' (simpleDecls ci)

@@ -64,7 +69,9 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

64 let bc = map toBC defs

69 let bc = map toBC defs

65 let wrappers = genWrappers bc

70 let wrappers = genWrappers bc

66 let h = concatMap toDecl (map fst bc)

71 let h = concatMap toDecl (map fst bc)

67− let cc = concatMap (uncurry toC) bc

72+ let (state, cc) = execRWS (generateSrc bc) 0

73+ (CS { fnName = Nothing,

74+ level = 1 })

68 let hi = concatMap ifaceC (concatMap getExp exports)

75 let hi = concatMap ifaceC (concatMap getExp exports)

69 d <- getIdrisCRTSDir

76 d <- getIdrisCRTSDir

70 mprog <- readFile (d </> "idris_main" <.> "c")

77 mprog <- readFile (d </> "idris_main" <.> "c")

@@ -134,12 +141,17 @@ creg Tmp = "REG1"

134toDecl :: Name -> String

141toDecl :: Name -> String

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

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

136

143

137−toC :: Name -> [BC] -> String

144+generateSrc :: [(Name, [BC])] -> RWS Int String CState ()

145+generateSrc bc = mapM_ toC bc

146+

147+toC :: (Name, [BC]) -> RWS Int String CState ()

138−toC f code

148+toC (f, code) = do

139− = -- "/* " ++ show code ++ "*/\n\n" ++

149+ modify (\s -> s { fnName = Just f })

150+ s <- get

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

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

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

152+ tell $ indent (level s) ++ "INITFRAME;\n"

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

153+ bcc code

154+ tell $ "}\n\n"

143

155

144showCStr :: String -> String

156showCStr :: String -> String

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

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

@@ -175,10 +187,22 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s

175 2 -> s

187 2 -> s

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

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

177

189

190+data CState = CS {

191+ fnName :: Maybe Name,

192+ level :: Int

193+}

194+

195+

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

196+bcc :: [BC] -> RWS Int String CState ()

197+bcc [] = return ()

198+bcc ((ASSIGN l r):xs) = do

199+ i <- get

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

200+ tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"

201+ bcc xs

180−bcc i (ASSIGNCONST l c)

202+bcc ((ASSIGNCONST l c):xs) = do

203+ i <- get

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

204+ tell $ indent (level i) ++ creg l ++ " = " ++ mkConst c ++ ";\n"

205+ bcc xs

182 where

206 where

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

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

184 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"

208 mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"

@@ -196,16 +220,21 @@ bcc i (ASSIGNCONST l c)

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

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

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

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

198

222

223+bcc ((UPDATE l r):xs) = do

224+ i <- get

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

225+ tell $ indent (level i) ++ creg l ++ " = " ++ creg r ++ ";\n"

226+ bcc xs

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

227+bcc ((MKCON l loc tag []):xs) | tag < 256 = do

228+ i <- get

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

229+ tell $ indent (level i) ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"

230+ bcc xs

202−bcc i (MKCON l loc tag args)

231+bcc ((MKCON l loc tag args):xs) = do

232+ i <- get

233+ let tab = indent (level i)

203− = indent i ++ alloc loc tag ++

234+ tell $ tab ++ alloc loc tag ++

204− indent i ++ setArgs 0 args ++ "\n" ++

235+ tab ++ setArgs 0 args ++ "\n" ++

205− indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

236+ tab ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

206−

237+ bcc xs

207−-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++

208−-- show (length args) ++ concatMap showArg args ++ ");\n"

209 where showArg r = ", " ++ creg r

238 where showArg r = ", " ++ creg r

210 setArgs i [] = ""

239 setArgs i [] = ""

211 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

240 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

@@ -217,52 +246,94 @@ bcc i (MKCON l loc tag args)

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

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

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

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

219

248

249+bcc ((PROJECT l loc a):xs) = do

250+ i <- get

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

251+ tell $ indent (level i) ++ "PROJECT(vm, " ++ creg l ++ ", "

221− ", " ++ show a ++ ");\n"

252+ ++ show loc ++ ", " ++ show a ++ ");\n"

253+ bcc xs

222−bcc i (PROJECTINTO r t idx)

254+bcc ((PROJECTINTO r t idx):xs) = do

255+ i <- get

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

256+ tell $ indent (level i) ++ creg r ++ " = GETARG(" ++ creg t

257+ ++ ", " ++ show idx ++ ");\n"

258+ bcc xs

224−bcc i (CASE True r code def)

259+bcc ((CASE True r code def):xs)

225− | length code < 4 = showCase i def code

260+ | length code < 4 = do

261+ showCases def code

262+ bcc xs

226 where

263 where

227− showCode :: Int -> [BC] -> String

264+ showCode bc = do

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

265+ w <- getBC bc xs

266+ i <- get

229− indent i ++ "}\n"

267+ tell $ "{\n" ++ w ++ indent (level i) ++ "}\n"

230−

268+

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

269+ showCases Nothing [(t, c)] = do

232− showCase i Nothing [(t, c)] = indent i ++ showCode i c

270+ i <- get

233− showCase i (Just def) [] = indent i ++ showCode i def

271+ tell $ indent (level i)

272+ showCode c

273+ showCases (Just def) [] = do

274+ i <- get

275+ tell $ indent (level i)

276+ showCode def

234− showCase i def ((t, c) : cs)

277+ showCases def ((t, c) : cs) = do

278+ i <- get

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

279+ tell $ indent (level i) ++ "if (CTAG(" ++ creg r ++ ") == "

280+ ++ show t ++ ") "

281+ showCode c

236− ++ indent i ++ "else\n" ++ showCase i def cs

282+ tell $ indent (level i) ++ "else\n"

237−

283+ showCases def cs

284+

238−bcc i (CASE safe r code def)

285+bcc ((CASE safe r code def):xs) = do

286+ i <- get

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

287+ tell $ indent (level i) ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n"

240− concatMap (showCase i) code ++

288+ mapM showCase code

241− showDef i def ++

289+ showDef def

242− indent i ++ "}\n"

290+ tell $ indent (level i) ++ "}\n"

291+ bcc xs

243 where

292 where

244 ctag True = "CTAG"

293 ctag True = "CTAG"

245 ctag False = "TAG"

294 ctag False = "TAG"

246

295

296+ showCase (t, bc) = do

297+ w <- getBC bc xs

298+ is <- get

299+ let i = level is

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

300+ tell $ indent i ++ "case " ++ show t ++ ":\n"

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

301+ ++ w ++ indent (i + 1) ++ "break;\n"

249− showDef i Nothing = ""

302+ showDef Nothing = return $ ()

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

303+ showDef (Just c) = do

304+ w <- getBC c xs

305+ is <- get

306+ let i = level is

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

307+ tell $ indent i ++ "default:\n" ++ w ++ indent (i + 1) ++ "break;\n"

308+

252−bcc i (CONSTCASE r code def)

309+bcc ((CONSTCASE r code def):xs)

253 | intConsts code

310 | intConsts code

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

311+ = do

255−-- concatMap (showCase i) code ++

312+ is <- get

256−-- showDef i def ++

313+ let i = level is

257−-- indent i ++ "}\n"

314+ codes <- mapM getCode code

258− = concatMap (iCase (creg r)) code ++

315+ defs <- showDefS def

259− indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

316+ tell $ concatMap (iCase i (creg r)) codes

317+ tell $ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"

318+ bcc xs

260 | strConsts code

319 | strConsts code

320+ = do

321+ is <- get

322+ let i = level is

323+ codes <- mapM getCode code

324+ defs <- showDefS def

261− = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++

325+ tell $ concatMap (strCase i ("GETSTR(" ++ creg r ++ ")")) codes

262− indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

326+ ++ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"

327+ bcc xs

263 | bigintConsts code

328 | bigintConsts code

329+ = do

330+ is <- get

331+ let i = level is

332+ codes <- mapM getCode code

333+ defs <- showDefS def

264− = concatMap (biCase (creg r)) code ++

334+ tell $ concatMap (biCase i (creg r)) codes ++

265− indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

335+ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"

336+ bcc xs

266 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code

337 | otherwise = error $ "Can't happen: Can't compile const case " ++ show code

267 where

338 where

268 intConsts ((I _, _ ) : _) = True

339 intConsts ((I _, _ ) : _) = True

@@ -279,72 +350,119 @@ bcc i (CONSTCASE r code def)

279 strConsts ((Str _, _ ) : _) = True

350 strConsts ((Str _, _ ) : _) = True

280 strConsts _ = False

351 strConsts _ = False

281

352

353+ getCode (x, code) = do

354+ c <- getBC code xs

355+ return (x, c)

356+

282− strCase sv (s, bc) =

357+ strCase i sv (s, bc) =

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

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

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

359+ bc ++ indent i ++ "} else\n"

285− biCase bv (BI b, bc) =

360+ biCase i bv (BI b, bc) =

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

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

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

362+ ++ bc ++ indent i ++ "} else\n"

288− iCase v (I b, bc) =

363+ iCase i v (I b, bc) =

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

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

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

365+ ++ bc ++ indent i ++ "} else\n"

291− iCase v (Ch b, bc) =

366+ iCase i v (Ch b, bc) =

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

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

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

368+ ++ bc ++ indent i ++ "} else\n"

294− iCase v (B8 w, bc) =

369+ iCase i v (B8 w, bc) =

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

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

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

371+ ++ bc ++ indent i ++ "} else\n"

297− iCase v (B16 w, bc) =

372+ iCase i v (B16 w, bc) =

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

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

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

374+ ++ bc ++ indent i ++ "} else\n"

300− iCase v (B32 w, bc) =

375+ iCase i v (B32 w, bc) =

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

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

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

377+ ++ bc ++ indent i ++ "} else\n"

303− iCase v (B64 w, bc) =

378+ iCase i v (B64 w, bc) =

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

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

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

380+ ++ bc ++ indent i ++ "} else\n"

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

381+

307− ++ concatMap (bcc (i+1)) bc ++

382+ showDefS Nothing = return ""

308− indent (i + 1) ++ "break;\n"

383+ showDefS (Just c) = getBC c xs

309− showDef i Nothing = ""

384+

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

385+bcc (CALL n:xs) = do

311− ++ concatMap (bcc (i+1)) c ++

386+ i <- get

312− indent (i + 1) ++ "break;\n"

313− showDefS i Nothing = ""

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

315−

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

387+ tell $ indent (level i) ++ "CALL(" ++ cname n ++ ");\n"

388+ bcc xs

389+bcc (TAILCALL n:xs) = do

390+ i <- get

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

391+ tell $ indent (level i) ++ "TAILCALL(" ++ cname n ++ ");\n"

392+ bcc xs

393+bcc ((SLIDE n):xs) = do

394+ i <- get

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

395+ tell $ indent (level i) ++ "SLIDE(vm, " ++ show n ++ ");\n"

396+ bcc xs

397+bcc (REBASE:xs) = do

398+ i <- get

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

399+ tell $ indent (level i)++ "REBASE;\n"

400+ bcc xs

320−bcc i (RESERVE 0) = ""

401+bcc ((RESERVE 0):xs) = bcc xs

402+bcc ((RESERVE n):xs) = do

403+ i <- get

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

404+ tell $ indent (level i) ++ "RESERVE(" ++ show n ++ ");\n"

405+ bcc xs

322−bcc i (ADDTOP 0) = ""

406+bcc ((ADDTOP 0):xs) = bcc xs

407+bcc ((ADDTOP n):xs) = do

408+ i <- get

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

409+ tell $ indent (level i) ++ "ADDTOP(" ++ show n ++ ");\n"

410+ bcc xs

411+bcc ((TOPBASE n):xs) = do

412+ i <- get

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

413+ tell $ indent (level i) ++ "TOPBASE(" ++ show n ++ ");\n"

414+ bcc xs

415+bcc ((BASETOP n):xs) = do

416+ i <- get

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

417+ tell $ indent (level i) ++ "BASETOP(" ++ show n ++ ");\n"

418+ bcc xs

419+bcc (STOREOLD:xs) = do

420+ i <- get

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

421+ tell $ indent (level i) ++ "STOREOLD;\n"

422+ bcc xs

423+bcc ((OP l fn args):xs) = do

424+ i <- get

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

425+ tell $ indent (level i) ++ doOp (creg l ++ " = ") fn args ++ ";\n"

426+ bcc xs

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

427+bcc ((FOREIGNCALL l rty (FStr fn@('&':name)) []):xs) = do

329− = indent i ++

428+ i <- get

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

429+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"

430+ bcc xs

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

431+bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%wrapper"

332− = indent i ++

432+ = do

433+ i <- get

333− c_irts (toFType rty) (creg l ++ " = ")

434+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")

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

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

436+ bcc zs

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

437+bcc ((FOREIGNCALL l rty (FStr fn) (x:xs)):zs) | fn == "%dynamic"

438+ = do

439+ i <- get

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

440+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")

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

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

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

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

443+ bcc zs

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

444+bcc ((FOREIGNCALL l rty (FStr fn) args):xs) = do

340− = indent i ++

445+ i <- get

341− c_irts (toFType rty) (creg l ++ " = ")

446+ tell $ indent (level i) ++ c_irts (toFType rty) (creg l ++ " = ")

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

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

448+ bcc xs

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

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

450+bcc ((NULL r):xs) = do

451+ i <- get

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

452+ tell $ indent (level i) ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

453+ bcc xs

454+bcc ((ERROR str):xs) = do

455+ i <- get

456+ tell $ indent (level i) ++ "fprintf(stderr, "

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

457+ ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

458+ bcc xs

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

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

347

460

461+getBC code xs = do

462+ i <- get

463+ let (a, s, w) = runRWS (bcc code) 0 (i { level = level i + 1 })

464+ return w

465+

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

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

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

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

350-- a foreign type description for c_irts and irts_c

468-- a foreign type description for c_irts and irts_c