e471a1c · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge pull request #3896 from melted/codegen_rws

e471a1cAhmad Salim Al-Sibahi9 years ago

src/IRTS/CodegenC.hs+232−115

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

@@ -19,10 +19,12 @@ import IRTS.System

19import Util.System

21import Control.Monad

22+import Control.Monad

23+import Control.Monad.RWS

22import Data.Bits

24import Data.Bits

23import Data.Char

25import Data.Char

24−import Data.List (intercalate, nubBy)

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

25−import Debug.Trace

27+import qualified Data.Text as T

26import Numeric

28import Numeric

27import System.Directory

29import System.Directory

28import System.Exit

30import System.Exit

@@ -30,6 +32,8 @@ import System.FilePath ((<.>), (</>))

30import System.IO

32import System.IO

31import System.Process

33import System.Process

35+import Debug.Trace

36+

33codegenC :: CodeGenerator

37codegenC :: CodeGenerator

34codegenC ci = do codegenC' (simpleDecls ci)

38codegenC ci = do codegenC' (simpleDecls ci)

35 (outputFile ci)

39 (outputFile ci)

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

64 let bc = map toBC defs

68 let bc = map toBC defs

65 let wrappers = genWrappers bc

69 let wrappers = genWrappers bc

66 let h = concatMap toDecl (map fst bc)

70 let h = concatMap toDecl (map fst bc)

67− let cc = concatMap (uncurry toC) bc

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

72+ (CS { fnName = Nothing,

73+ level = 1 })

68 let hi = concatMap ifaceC (concatMap getExp exports)

74 let hi = concatMap ifaceC (concatMap getExp exports)

69 d <- getIdrisCRTSDir

75 d <- getIdrisCRTSDir

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

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

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

134toDecl :: Name -> String

140toDecl :: Name -> String

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

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

136

142

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

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

144+generateSrc bc = mapM_ toC bc

145+

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

138−toC f code

147+toC (f, code) = do

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

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

149+ s <- get

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

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

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

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

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

152+ bcc code

153+ tell $ "}\n\n"

143

154

144showCStr :: String -> String

155showCStr :: String -> String

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

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

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

175 2 -> s

186 2 -> s

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

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

177

188

189+data CState = CS {

190+ fnName :: Maybe Name,

191+ level :: Int

192+}

193+

194+

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

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

196+bcc [] = return ()

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

198+ i <- get

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

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

200+ bcc xs

180−bcc i (ASSIGNCONST l c)

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

202+ i <- get

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

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

204+ bcc xs

182 where

205 where

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

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

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

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

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

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

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

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

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

198

221

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

223+ i <- get

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

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

225+ bcc xs

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

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

227+ i <- get

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

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

229+ bcc xs

202−bcc i (MKCON l loc tag args)

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

231+ i <- get

232+ let tab = indent (level i)

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

233+ tell $ tab ++ alloc loc tag ++

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

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

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

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

206−

236+ bcc xs

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

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

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

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

210 setArgs i [] = ""

238 setArgs i [] = ""

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

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

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

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

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

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

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

219

247

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

249+ i <- get

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

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

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

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

252+ bcc xs

222−bcc i (PROJECTINTO r t idx)

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

254+ i <- get

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

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

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

257+ bcc xs

224−bcc i (CASE True r code def)

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

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

259+ | length code < 4 = do

260+ showCases def code

261+ bcc xs

226 where

262 where

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

263+ showCode bc = do

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

264+ w <- getBC bc xs

265+ i <- get

229− indent i ++ "}\n"

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

230−

267+

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

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

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

269+ i <- get

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

270+ tell $ indent (level i)

271+ showCode c

272+ showCases (Just def) [] = do

273+ i <- get

274+ tell $ indent (level i)

275+ showCode def

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

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

277+ i <- get

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

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

279+ ++ show t ++ ") "

280+ showCode c

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

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

237−

282+ showCases def cs

283+

238−bcc i (CASE safe r code def)

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

285+ i <- get

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

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

240− concatMap (showCase i) code ++

287+ mapM showCase code

241− showDef i def ++

288+ showDef def

242− indent i ++ "}\n"

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

290+ bcc xs

243 where

291 where

244 ctag True = "CTAG"

292 ctag True = "CTAG"

245 ctag False = "TAG"

293 ctag False = "TAG"

246

294

295+ showCase (t, bc) = do

296+ w <- getBC bc xs

297+ is <- get

298+ let i = level is

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

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

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

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

249− showDef i Nothing = ""

301+ showDef Nothing = return $ ()

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

302+ showDef (Just c) = do

303+ w <- getBC c xs

304+ is <- get

305+ let i = level is

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

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

307+

252−bcc i (CONSTCASE r code def)

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

253 | intConsts code

309 | intConsts code

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

310+ = do

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

311+ is <- get

256−-- showDef i def ++

312+ let i = level is

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

313+ codes <- mapM getCode code

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

314+ defs <- showDefS def

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

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

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

317+ bcc xs

260 | strConsts code

318 | strConsts code

319+ = do

320+ is <- get

321+ let i = level is

322+ codes <- mapM getCode code

323+ defs <- showDefS def

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

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

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

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

326+ bcc xs

263 | bigintConsts code

327 | bigintConsts code

328+ = do

329+ is <- get

330+ let i = level is

331+ codes <- mapM getCode code

332+ defs <- showDefS def

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

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

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

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

335+ bcc xs

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

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

267 where

337 where

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

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

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

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

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

280 strConsts _ = False

350 strConsts _ = False

281

351

352+ getCode (x, code) = do

353+ c <- getBC code xs

354+ return (x, c)

355+

282− strCase sv (s, bc) =

356+ strCase i sv (s, bc) =

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

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

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

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

285− biCase bv (BI b, bc) =

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

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

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

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

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

288− iCase v (I b, bc) =

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

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

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

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

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

291− iCase v (Ch b, bc) =

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

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

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

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

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

294− iCase v (B8 w, bc) =

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

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

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

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

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

297− iCase v (B16 w, bc) =

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

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

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

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

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

300− iCase v (B32 w, bc) =

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

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

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

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

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

303− iCase v (B64 w, bc) =

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

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

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

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

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

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

380+

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

381+ showDefS Nothing = return ""

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

382+ showDefS (Just c) = getBC c xs

309− showDef i Nothing = ""

383+

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

384+bcc (CALL n:xs) = do

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

385+ 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"

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

387+ bcc xs

388+bcc (TAILCALL n:xs) = do

389+ i <- get

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

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

391+ bcc xs

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

393+ i <- get

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

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

395+ bcc xs

396+bcc (REBASE:xs) = do

397+ i <- get

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

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

399+ bcc xs

320−bcc i (RESERVE 0) = ""

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

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

402+ i <- get

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

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

404+ bcc xs

322−bcc i (ADDTOP 0) = ""

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

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

407+ i <- get

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

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

409+ bcc xs

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

411+ i <- get

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

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

413+ bcc xs

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

415+ i <- get

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

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

417+ bcc xs

418+bcc (STOREOLD:xs) = do

419+ i <- get

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

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

421+ bcc xs

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

423+ i <- get

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

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

425+ bcc xs

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

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

329− = indent i ++

427+ i <- get

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

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

429+ bcc xs

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

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

332− = indent i ++

431+ = do

432+ i <- get

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

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

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

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

435+ bcc zs

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

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

437+ = do

438+ i <- get

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

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

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

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

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

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

442+ bcc zs

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

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

340− = indent i ++

444+ i <- get

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

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

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

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

447+ bcc xs

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

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

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

450+ i <- get

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

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

452+ bcc xs

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

454+ i <- get

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

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

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

457+ bcc xs

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

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

347

459

460+getBC code xs = do

461+ i <- get

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

463+ return w

464+

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

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

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

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

350-- a foreign type description for c_irts and irts_c

467-- a foreign type description for c_irts and irts_c