b5424df · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Revert "Merge pull request #3896 from melted/codegen_rws"

b5424dfNiklas Larsson9 years ago

src/IRTS/CodegenC.hs+115−232

compare with master

unifiedsplit

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

10module IRTS.CodegenC (codegenC) where

12−import Idris.AbsSyntax hiding (getBC)

12+import Idris.AbsSyntax

13import Idris.Core.TT

14import IRTS.Bytecode

15import IRTS.CodegenCommon

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

21import Util.System

23import Control.Monad

24−import Control.Monad

25−import Control.Monad.RWS

26import Data.Bits

24import Data.Bits

27import Data.Char

25import Data.Char

28−import Data.List (find, intercalate, nubBy, partition)

26+import Data.List (intercalate, nubBy)

29−import qualified Data.Text as T

27+import Debug.Trace

30import Numeric

28import Numeric

31import System.Directory

29import System.Directory

32import System.Exit

30import System.Exit

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

34import System.IO

32import System.IO

35import System.Process

33import System.Process

37−import Debug.Trace

38−

39codegenC :: CodeGenerator

35codegenC :: CodeGenerator

40codegenC ci = do codegenC' (simpleDecls ci)

36codegenC ci = do codegenC' (simpleDecls ci)

41 (outputFile ci)

37 (outputFile ci)

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

70 let bc = map toBC defs

66 let bc = map toBC defs

71 let wrappers = genWrappers bc

67 let wrappers = genWrappers bc

72 let h = concatMap toDecl (map fst bc)

68 let h = concatMap toDecl (map fst bc)

73− let (state, cc) = execRWS (generateSrc bc) 0

69+ let cc = concatMap (uncurry toC) bc

74− (CS { fnName = Nothing,

75− level = 1 })

76 let hi = concatMap ifaceC (concatMap getExp exports)

70 let hi = concatMap ifaceC (concatMap getExp exports)

77 d <- getIdrisCRTSDir

71 d <- getIdrisCRTSDir

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

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

@@ -142,17 +136,12 @@ creg Tmp = "REG1"

142toDecl :: Name -> String

136toDecl :: Name -> String

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

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

144

138

145−generateSrc :: [(Name, [BC])] -> RWS Int String CState ()

139+toC :: Name -> [BC] -> String

146−generateSrc bc = mapM_ toC bc

147−

148−toC :: (Name, [BC]) -> RWS Int String CState ()

149−toC (f, code) = do

140+toC f code

150− modify (\s -> s { fnName = Just f })

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

151− s <- get

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

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

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

143+ indent 1 ++ "INITFRAME;\n" ++

154− bcc code

144+ concatMap (bcc 1) code ++ "}\n\n"

155− tell $ "}\n\n"

156

145

157showCStr :: String -> String

146showCStr :: String -> String

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

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

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

188 2 -> s

177 2 -> s

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

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

190

179

191−data CState = CS {

192− fnName :: Maybe Name,

193− level :: Int

194−}

195−

196−

197−bcc :: [BC] -> RWS Int String CState ()

180+bcc :: Int -> BC -> String

198−bcc [] = return ()

199−bcc ((ASSIGN l r):xs) = do

200− i <- get

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

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

202− bcc xs

203−bcc ((ASSIGNCONST l c):xs) = do

182+bcc i (ASSIGNCONST l c)

204− i <- get

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

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

206− bcc xs

207 where

184 where

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

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

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

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

@@ -221,21 +198,16 @@ bcc ((ASSIGNCONST l c):xs) = do

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

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

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

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

223

200

224−bcc ((UPDATE l r):xs) = do

225− i <- get

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

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

227− bcc xs

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

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

229− i <- get

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

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

231− bcc xs

232−bcc ((MKCON l loc tag args):xs) = do

204+bcc i (MKCON l loc tag args)

233− i <- get

234− let tab = indent (level i)

235− tell $ tab ++ alloc loc tag ++

205+ = indent i ++ alloc loc tag ++

236− tab ++ setArgs 0 args ++ "\n" ++

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

237− tab ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

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

238− bcc xs

208+

209+-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++

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

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

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

240 setArgs i [] = ""

212 setArgs i [] = ""

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

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

@@ -247,94 +219,52 @@ bcc ((MKCON l loc tag args):xs) = do

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

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

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

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

249

221

250−bcc ((PROJECT l loc a):xs) = do

251− i <- get

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

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

253− ++ show loc ++ ", " ++ show a ++ ");\n"

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

254− bcc xs

255−bcc ((PROJECTINTO r t idx):xs) = do

224+bcc i (PROJECTINTO r t idx)

256− i <- get

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

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

258− ++ ", " ++ show idx ++ ");\n"

259− bcc xs

260−bcc ((CASE True r code def):xs)

226+bcc i (CASE True r code def)

261− | length code < 4 = do

227+ | length code < 4 = showCase i def code

262− showCases def code

263− bcc xs

264 where

228 where

265− showCode bc = do

229+ showCode :: Int -> [BC] -> String

266− w <- getBC bc xs

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

267− i <- get

231+ indent i ++ "}\n"

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

232+

269−

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

270− showCases Nothing [(t, c)] = do

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

271− i <- get

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

272− tell $ indent (level i)

273− showCode c

274− showCases (Just def) [] = do

275− i <- get

276− tell $ indent (level i)

277− showCode def

278− showCases def ((t, c) : cs) = do

236+ showCase i def ((t, c) : cs)

279− i <- get

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

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

281− ++ show t ++ ") "

282− showCode c

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

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

284− showCases def cs

239+

285−

286−bcc ((CASE safe r code def):xs) = do

240+bcc i (CASE safe r code def)

287− i <- get

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

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

289− mapM showCase code

242+ concatMap (showCase i) code ++

290− showDef def

243+ showDef i def ++

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

244+ indent i ++ "}\n"

292− bcc xs

293 where

245 where

294 ctag True = "CTAG"

246 ctag True = "CTAG"

295 ctag False = "TAG"

247 ctag False = "TAG"

296

248

297− showCase (t, bc) = do

298− w <- getBC bc xs

299− is <- get

300− let i = level is

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

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

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

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

303− showDef Nothing = return $ ()

251+ showDef i Nothing = ""

304− showDef (Just c) = do

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

305− w <- getBC c xs

306− is <- get

307− let i = level is

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

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

309−

310−bcc ((CONSTCASE r code def):xs)

254+bcc i (CONSTCASE r code def)

311 | intConsts code

255 | intConsts code

312− = do

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

313− is <- get

257+-- concatMap (showCase i) code ++

314− let i = level is

258+-- showDef i def ++

315− codes <- mapM getCode code

259+-- indent i ++ "}\n"

316− defs <- showDefS def

317− tell $ concatMap (iCase i (creg r)) codes

260+ = concatMap (iCase (creg r)) code ++

318− tell $ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"

261+ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

319− bcc xs

320 | strConsts code

262 | strConsts code

321− = do

322− is <- get

323− let i = level is

324− codes <- mapM getCode code

325− defs <- showDefS def

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

263+ = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code ++

327− ++ indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"

264+ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

328− bcc xs

329 | bigintConsts code

265 | bigintConsts code

330− = do

331− is <- get

332− let i = level is

333− codes <- mapM getCode code

334− defs <- showDefS def

335− tell $ concatMap (biCase i (creg r)) codes ++

266+ = concatMap (biCase (creg r)) code ++

336− indent i ++ "{\n" ++ defs ++ indent i ++ "}\n"

267+ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"

337− bcc xs

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

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

339 where

269 where

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

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

@@ -351,119 +281,72 @@ bcc ((CONSTCASE r code def):xs)

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

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

352 strConsts _ = False

282 strConsts _ = False

353

283

354− getCode (x, code) = do

355− c <- getBC code xs

356− return (x, c)

357−

358− strCase i sv (s, bc) =

284+ strCase sv (s, bc) =

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

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

360− bc ++ indent i ++ "} else\n"

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

361− biCase i bv (BI b, bc) =

287+ biCase bv (BI b, bc) =

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

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

363− ++ bc ++ indent i ++ "} else\n"

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

364− iCase i v (I b, bc) =

290+ iCase v (I b, bc) =

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

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

366− ++ bc ++ indent i ++ "} else\n"

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

367− iCase i v (Ch b, bc) =

293+ iCase v (Ch b, bc) =

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

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

369− ++ bc ++ indent i ++ "} else\n"

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

370− iCase i v (B8 w, bc) =

296+ iCase v (B8 w, bc) =

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

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

372− ++ bc ++ indent i ++ "} else\n"

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

373− iCase i v (B16 w, bc) =

299+ iCase v (B16 w, bc) =

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

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

375− ++ bc ++ indent i ++ "} else\n"

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

376− iCase i v (B32 w, bc) =

302+ iCase v (B32 w, bc) =

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

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

378− ++ bc ++ indent i ++ "} else\n"

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

379− iCase i v (B64 w, bc) =

305+ iCase v (B64 w, bc) =

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

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

381− ++ bc ++ indent i ++ "} else\n"

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

382−

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

383− showDefS Nothing = return ""

309+ ++ concatMap (bcc (i+1)) bc ++

384− showDefS (Just c) = getBC c xs

310+ indent (i + 1) ++ "break;\n"

385−

311+ showDef i Nothing = ""

386−bcc (CALL n:xs) = do

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

387− i <- get

313+ ++ concatMap (bcc (i+1)) c ++

314+ indent (i + 1) ++ "break;\n"

315+ showDefS i Nothing = ""

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

317+

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

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

389− bcc xs

390−bcc (TAILCALL n:xs) = do

391− i <- get

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

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

393− bcc xs

394−bcc ((SLIDE n):xs) = do

395− i <- get

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

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

397− bcc xs

398−bcc (REBASE:xs) = do

399− i <- get

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

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

401− bcc xs

402−bcc ((RESERVE 0):xs) = bcc xs

322+bcc i (RESERVE 0) = ""

403−bcc ((RESERVE n):xs) = do

404− i <- get

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

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

406− bcc xs

407−bcc ((ADDTOP 0):xs) = bcc xs

324+bcc i (ADDTOP 0) = ""

408−bcc ((ADDTOP n):xs) = do

409− i <- get

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

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

411− bcc xs

412−bcc ((TOPBASE n):xs) = do

413− i <- get

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

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

415− bcc xs

416−bcc ((BASETOP n):xs) = do

417− i <- get

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

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

419− bcc xs

420−bcc (STOREOLD:xs) = do

421− i <- get

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

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

423− bcc xs

424−bcc ((OP l fn args):xs) = do

425− i <- get

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

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

427− bcc xs

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

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

429− i <- get

331+ = indent i ++

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

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

431− bcc xs

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

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

433− = do

334+ = indent i ++

434− i <- get

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

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

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

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

437− bcc zs

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

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

439− = do

440− i <- get

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

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

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

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

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

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

444− bcc zs

445−bcc ((FOREIGNCALL l rty (FStr fn) args):xs) = do

341+bcc i (FOREIGNCALL l rty (FStr fn) args)

446− i <- get

342+ = indent i ++

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

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

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

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

449− bcc xs

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

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

451−bcc ((NULL r):xs) = do

452− i <- get

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

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

454− bcc xs

455−bcc ((ERROR str):xs) = do

456− i <- get

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

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

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

459− bcc xs

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

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

461

349

462−getBC code xs = do

463− i <- get

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

465− return w

466−

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

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

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

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

469-- a foreign type description for c_irts and irts_c

352-- a foreign type description for c_irts and irts_c