93992c3 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Compile Nat as Int, (and plus/mult/fromInteger)

93992c3Edwin Brady13 years ago

lib/Prelude/Nat.idr+15−12

compare with master

unifiedsplit

@@ -36,6 +36,19 @@ total mult : Nat -> Nat -> Nat

36mult Z right = Z

37mult (S left) right = plus right $ mult left right

39+%assert_total

40+fromIntegerNat : Integer -> Nat

41+fromIntegerNat 0 = Z

42+fromIntegerNat n =

43+ if (n > 0) then

44+ S (fromIntegerNat (n - 1))

45+ else

46+ Z

47+

48+toIntegerNat : Nat -> Integer

49+toIntegerNat Z = 0

50+toIntegerNat (S k) = 1 + toIntegerNat k

51+

39total minus : Nat -> Nat -> Nat

52total minus : Nat -> Nat -> Nat

40minus Z right = Z

53minus Z right = Z

41minus left Z = left

54minus left Z = left

@@ -108,8 +121,7 @@ instance Eq Nat where

108 _ == _ = False

121 _ == _ = False

109

122

110instance Cast Nat Integer where

123instance Cast Nat Integer where

111− cast Z = 0

124+ cast = toIntegerNat

112− cast (S k) = 1 + cast k

113

125

114instance Ord Nat where

126instance Ord Nat where

115 compare Z Z = EQ

127 compare Z Z = EQ

@@ -124,16 +136,7 @@ instance Num Nat where

124

136

125 abs x = x

137 abs x = x

126

138

127− fromInteger x = fromInteger' x

139+ fromInteger = fromIntegerNat

128− where

129− %assert_total

130− fromInteger' : Integer -> Nat

131− fromInteger' 0 = Z

132− fromInteger' n =

133− if (n > 0) then

134− S (fromInteger' (n - 1))

135− else

136− Z

137

140

138instance Cast Integer Nat where

141instance Cast Integer Nat where

139 cast = fromInteger

142 cast = fromInteger

src/Core/CaseTree.hs+32−2

@@ -29,6 +29,7 @@ type SC = SC' Term

29data CaseAlt' t = ConCase Name Int [Name] (SC' t)

30 | FnCase Name [Name] (SC' t) -- ^ reflection function

31 | ConstCase Const (SC' t)

32+ | SucCase Name (SC' t)

32 | DefaultCase (SC' t)

33 | DefaultCase (SC' t)

33 deriving (Show, Eq, Ord, Functor)

34 deriving (Show, Eq, Ord, Functor)

34{-!

35{-!

@@ -58,6 +59,8 @@ instance Show t => Show (SC' t) where

58 ++ show' (i+1) sc

59 ++ show' (i+1) sc

59 showA i (ConstCase t sc)

60 showA i (ConstCase t sc)

60 = show t ++ " => " ++ show' (i+1) sc

61 = show t ++ " => " ++ show' (i+1) sc

62+ showA i (SucCase n sc)

63+ = show n ++ "+1 => " ++ show' (i+1) sc

61 showA i (DefaultCase sc)

64 showA i (DefaultCase sc)

62 = "_ => " ++ show' (i+1) sc

65 = "_ => " ++ show' (i+1) sc

@@ -76,6 +79,7 @@ instance TermSize CaseAlt where

76 termsize n (ConCase _ _ _ s) = termsize n s

79 termsize n (ConCase _ _ _ s) = termsize n s

77 termsize n (FnCase _ _ s) = termsize n s

80 termsize n (FnCase _ _ s) = termsize n s

78 termsize n (ConstCase _ s) = termsize n s

81 termsize n (ConstCase _ s) = termsize n s

82+ termsize n (SucCase _ s) = termsize n s

79 termsize n (DefaultCase s) = termsize n s

83 termsize n (DefaultCase s) = termsize n s

81-- simple terms can be inlined trivially - good for primitives in particular

85-- simple terms can be inlined trivially - good for primitives in particular

@@ -98,6 +102,7 @@ namesUsed sc = nub $ nu' [] sc where

98 nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) \\ args

102 nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc) \\ args

99 nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) \\ args

103 nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc) \\ args

100 nua ps (ConstCase _ sc) = nu' ps sc

104 nua ps (ConstCase _ sc) = nu' ps sc

105+ nua ps (SucCase _ sc) = nu' ps sc

101 nua ps (DefaultCase sc) = nu' ps sc

106 nua ps (DefaultCase sc) = nu' ps sc

102

107

103 nut ps (P _ n _) | n `elem` ps = []

108 nut ps (P _ n _) | n `elem` ps = []

@@ -122,6 +127,7 @@ findCalls sc topargs = nub $ nu' topargs sc where

122 nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc)

127 nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc)

123 nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc)

128 nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc)

124 nua ps (ConstCase _ sc) = nu' ps sc

129 nua ps (ConstCase _ sc) = nu' ps sc

130+ nua ps (SucCase _ sc) = nu' ps sc

125 nua ps (DefaultCase sc) = nu' ps sc

131 nua ps (DefaultCase sc) = nu' ps sc

126

132

127 nut ps (P Ref n _) | n `elem` ps = []

133 nut ps (P Ref n _) | n `elem` ps = []

@@ -166,6 +172,7 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

166 nua (ConCase n i args sc) = nu' sc

172 nua (ConCase n i args sc) = nu' sc

167 nua (FnCase n args sc) = nu' sc

173 nua (FnCase n args sc) = nu' sc

168 nua (ConstCase _ sc) = nu' sc

174 nua (ConstCase _ sc) = nu' sc

175+ nua (SucCase _ sc) = nu' sc

169 nua (DefaultCase sc) = nu' sc

176 nua (DefaultCase sc) = nu' sc

170

177

171data Phase = CompileTime | RunTime

178data Phase = CompileTime | RunTime

@@ -212,11 +219,13 @@ simpleCase tc cover reflect phase fc cs

212 acc [] n = Error (Inaccessible n)

219 acc [] n = Error (Inaccessible n)

213 acc (PV x : xs) n | x == n = OK ()

220 acc (PV x : xs) n | x == n = OK ()

214 acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n

221 acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n

222+ acc (PSuc p : xs) n = acc (p : xs) n

215 acc (_ : xs) n = acc xs n

223 acc (_ : xs) n = acc xs n

216

224

217data Pat = PCon Name Int [Pat]

225data Pat = PCon Name Int [Pat]

218 | PConst Const

226 | PConst Const

219 | PV Name

227 | PV Name

228+ | PSuc Pat -- special case for n+1 on Integer

220 | PReflected Name [Pat]

229 | PReflected Name [Pat]

221 | PAny

230 | PAny

222 deriving Show

231 deriving Show

@@ -234,6 +243,11 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

234 where

243 where

235 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

244 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

236 return $ PCon n t args'

245 return $ PCon n t args'

246+ -- n + 1

247+ toPat' (P _ (UN "prim__addBigInt") _)

248+ [p, Constant (BI 1)]

249+ = do p' <- toPat' p []

250+ return $ PSuc p'

237 -- Typecase

251 -- Typecase

238 toPat' (P (TCon t a) n _) args | tc

252 toPat' (P (TCon t a) n _) args | tc

239 = do args' <- mapM (\x -> toPat' x []) args

253 = do args' <- mapM (\x -> toPat' x []) args

@@ -280,6 +294,7 @@ isVarPat _ = False

280

294

281isConPat (PCon _ _ _ : ps, _) = True

295isConPat (PCon _ _ _ : ps, _) = True

282isConPat (PReflected _ _ : ps, _) = True

296isConPat (PReflected _ _ : ps, _) = True

297+isConPat (PSuc _ : ps, _) = True

283isConPat (PConst _ : ps, _) = True

298isConPat (PConst _ : ps, _) = True

284isConPat _ = False

299isConPat _ = False

285

300

@@ -338,11 +353,13 @@ mixture vs (Vars ms : ps) err = do fallthrough <- mixture vs ps err

338

353

339data ConType = CName Name Int -- named constructor

354data ConType = CName Name Int -- named constructor

340 | CFn Name -- reflected function name

355 | CFn Name -- reflected function name

356+ | CSuc -- n+1

341 | CConst Const -- constant, not implemented yet

357 | CConst Const -- constant, not implemented yet

342− deriving Eq

358+ deriving (Show, Eq)

343

359

344data Group = ConGroup ConType -- Constructor

360data Group = ConGroup ConType -- Constructor

345 [([Pat], Clause)] -- arguments and rest of alternative

361 [([Pat], Clause)] -- arguments and rest of alternative

362+ deriving Show

346

363

347conRule :: [Name] -> [Clause] -> SC -> State CS SC

364conRule :: [Name] -> [Clause] -> SC -> State CS SC

348conRule (v:vs) cs err = do groups <- groupCons cs

365conRule (v:vs) cs err = do groups <- groupCons cs

@@ -361,6 +378,10 @@ caseGroups (v:vs) gs err = do g <- altGroups gs

361 = do g <- altFnGroup n args

378 = do g <- altFnGroup n args

362 rest <- altGroups cs

379 rest <- altGroups cs

363 return (g : rest)

380 return (g : rest)

381+ altGroups (ConGroup CSuc args : cs)

382+ = do g <- altSucGroup args

383+ rest <- altGroups cs

384+ return (g : rest)

364 altGroups (ConGroup (CConst c) args : cs)

385 altGroups (ConGroup (CConst c) args : cs)

365 = do g <- altConstGroup c args

386 = do g <- altConstGroup c args

366 rest <- altGroups cs

387 rest <- altGroups cs

@@ -372,6 +393,9 @@ caseGroups (v:vs) gs err = do g <- altGroups gs

372 altFnGroup n gs = do (newArgs, nextCs) <- argsToAlt gs

393 altFnGroup n gs = do (newArgs, nextCs) <- argsToAlt gs

373 matchCs <- match (newArgs ++ vs) nextCs err

394 matchCs <- match (newArgs ++ vs) nextCs err

374 return $ FnCase n newArgs matchCs

395 return $ FnCase n newArgs matchCs

396+ altSucGroup gs = do ([newArg], nextCs) <- argsToAlt gs

397+ matchCs <- match (newArg:vs) nextCs err

398+ return $ SucCase newArg matchCs

375 altConstGroup n gs = do (_, nextCs) <- argsToAlt gs

399 altConstGroup n gs = do (_, nextCs) <- argsToAlt gs

376 matchCs <- match vs nextCs err

400 matchCs <- match vs nextCs err

377 return $ ConstCase n matchCs

401 return $ ConstCase n matchCs

@@ -411,6 +435,7 @@ groupCons cs = gc [] cs

411 addGroup p ps res acc = case p of

435 addGroup p ps res acc = case p of

412 PCon con i args -> return $ addg (CName con i) args (ps, res) acc

436 PCon con i args -> return $ addg (CName con i) args (ps, res) acc

413 PConst cval -> return $ addConG cval (ps, res) acc

437 PConst cval -> return $ addConG cval (ps, res) acc

438+ PSuc n -> return $ addg CSuc [n] (ps, res) acc

414 PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc

439 PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc

415 pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)"

440 pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)"

416

441

@@ -423,7 +448,8 @@ groupCons cs = gc [] cs

423 addConG con res [] = [ConGroup (CConst con) [([], res)]]

448 addConG con res [] = [ConGroup (CConst con) [([], res)]]

424 addConG con res (g@(ConGroup (CConst n) cs) : gs)

449 addConG con res (g@(ConGroup (CConst n) cs) : gs)

425 | con == n = ConGroup (CConst n) (cs ++ [([], res)]) : gs

450 | con == n = ConGroup (CConst n) (cs ++ [([], res)]) : gs

426− | otherwise = g : addConG con res gs

451+-- | otherwise = g : addConG con res gs

452+ addConG con res (g : gs) = g : addConG con res gs

427

453

428varRule :: [Name] -> [Clause] -> SC -> State CS SC

454varRule :: [Name] -> [Clause] -> SC -> State CS SC

429varRule (v : vs) alts err =

455varRule (v : vs) alts err =

@@ -448,6 +474,7 @@ depatt ns tm = dp [] tm

448 dpa ms x (FnCase n args sc)

474 dpa ms x (FnCase n args sc)

449 = FnCase n args (dp ((x, (n, args)) : ms) sc)

475 = FnCase n args (dp ((x, (n, args)) : ms) sc)

450 dpa ms x (ConstCase c sc) = ConstCase c (dp ms sc)

476 dpa ms x (ConstCase c sc) = ConstCase c (dp ms sc)

477+ dpa ms x (SucCase n sc) = SucCase n (dp ms sc)

451 dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc)

478 dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc)

452

479

453 applyMaps ms f@(App _ _)

480 applyMaps ms f@(App _ _)

@@ -478,6 +505,7 @@ prune proj (Case n alts)

478 where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

505 where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

479 pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

506 pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

480 pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

507 pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

508+ pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

481 pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

509 pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

482

510

483 notErased (DefaultCase (STerm Erased)) = False

511 notErased (DefaultCase (STerm Erased)) = False

@@ -503,6 +531,8 @@ prune proj (Case n alts)

503 = FnCase cn args (projRep arg n i rhs)

531 = FnCase cn args (projRep arg n i rhs)

504 projRepAlt arg n i (ConstCase t rhs)

532 projRepAlt arg n i (ConstCase t rhs)

505 = ConstCase t (projRep arg n i rhs)

533 = ConstCase t (projRep arg n i rhs)

534+ projRepAlt arg n i (SucCase sn rhs)

535+ = SucCase sn (projRep arg n i rhs)

506 projRepAlt arg n i (DefaultCase rhs)

536 projRepAlt arg n i (DefaultCase rhs)

507 = DefaultCase (projRep arg n i rhs)

537 = DefaultCase (projRep arg n i rhs)

508

538

src/Core/Evaluate.hs+9−1

@@ -343,10 +343,13 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

343 | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc)

344 | Just v <- findDefault alts = return $ Just (amap, v)

345 chooseAlt env _ (VP (TCon i a) _ _, args) alts amap

346+ | Just (ns, sc) <- findTag i alts

346− | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc)

347+ = return $ Just (updateAmap (zip ns args) amap, sc)

347 | Just v <- findDefault alts = return $ Just (amap, v)

348 | Just v <- findDefault alts = return $ Just (amap, v)

348 chooseAlt env _ (VConstant c, []) alts amap

349 chooseAlt env _ (VConstant c, []) alts amap

349 | Just v <- findConst c alts = return $ Just (amap, v)

350 | Just v <- findConst c alts = return $ Just (amap, v)

351+ | Just (n', sub, sc) <- findSuc c alts

352+ = return $ Just (updateAmap [(n',sub)] amap, sc)

350 | Just v <- findDefault alts = return $ Just (amap, v)

353 | Just v <- findDefault alts = return $ Just (amap, v)

351 chooseAlt env _ (VP _ n _, args) alts amap

354 chooseAlt env _ (VP _ n _, args) alts amap

352 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

355 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

@@ -381,6 +384,11 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

381 findDefault (DefaultCase sc : xs) = Just sc

384 findDefault (DefaultCase sc : xs) = Just sc

382 findDefault (_ : xs) = findDefault xs

385 findDefault (_ : xs) = findDefault xs

383

386

387+ findSuc c [] = Nothing

388+ findSuc (BI val) (SucCase n sc : _)

389+ | val /= 0 = Just (n, VConstant (BI (val - 1)), sc)

390+ findSuc c (_ : xs) = findSuc c xs

391+

384 findConst c [] = Nothing

392 findConst c [] = Nothing

385 findConst c (ConstCase c' v : xs) | c == c' = Just v

393 findConst c (ConstCase c' v : xs) | c == c' = Just v

386 findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v

394 findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v

src/IRTS/Compiler.hs+6

@@ -379,6 +379,12 @@ instance ToIR SC where

379 | matchableTy x

380 = do rhs' <- ir rhs

381 return $ LDefaultCase rhs'

382+ mkIRAlt (P _ orig _) (SucCase n rhs)

383+ = do rhs' <- ir rhs

384+ return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

385+ [LV (Glob orig),

386+ LConst (BI 1)]) rhs')

387+-- return $ LSucCase n rhs'

382 mkIRAlt _ (ConstCase c rhs)

388 mkIRAlt _ (ConstCase c rhs)

383 = fail $ "Can't match on (" ++ show c ++ ")"

389 = fail $ "Can't match on (" ++ show c ++ ")"

384 mkIRAlt _ (DefaultCase rhs)

390 mkIRAlt _ (DefaultCase rhs)

src/IRTS/Defunctionalise.hs+2−1

@@ -286,13 +286,14 @@ mkBigCase cn max arg branches

286 tagOrd (DConCase t _ _ _) (DConCase t' _ _ _) = compare t t'

287 tagOrd (DConstCase c _) (DConstCase c' _) = compare c c'

288 tagOrd (DDefaultCase _) (DDefaultCase _) = EQ

289+

289 tagOrd (DConCase _ _ _ _) (DDefaultCase _) = LT

290 tagOrd (DConCase _ _ _ _) (DDefaultCase _) = LT

290 tagOrd (DConCase _ _ _ _) (DConstCase _ _) = LT

291 tagOrd (DConCase _ _ _ _) (DConstCase _ _) = LT

291 tagOrd (DConstCase _ _) (DDefaultCase _) = LT

292 tagOrd (DConstCase _ _) (DDefaultCase _) = LT

293+

292 tagOrd (DDefaultCase _) (DConCase _ _ _ _) = GT

294 tagOrd (DDefaultCase _) (DConCase _ _ _ _) = GT

293 tagOrd (DConstCase _ _) (DConCase _ _ _ _) = GT

295 tagOrd (DConstCase _ _) (DConCase _ _ _ _) = GT

294 tagOrd (DDefaultCase _) (DConstCase _ _) = GT

296 tagOrd (DDefaultCase _) (DConstCase _ _) = GT

295−

296

297

297groupsOf :: Int -> [DAlt] -> [[DAlt]]

298groupsOf :: Int -> [DAlt] -> [[DAlt]]

298groupsOf x [] = []

299groupsOf x [] = []

src/IRTS/Java/Mangling.hs+1

@@ -18,6 +18,7 @@ import Language.Java.Syntax hiding (Name)

18import qualified Language.Java.Syntax as J

20import System.FilePath

21+import Debug.Trace

22prefixCallNamespaces :: Ident -> SDecl -> SDecl

23prefixCallNamespaces :: Ident -> SDecl -> SDecl

23prefixCallNamespaces name (SFun fname args i e) =

24prefixCallNamespaces name (SFun fname args i e) =

src/Idris/DataOpts.hs+17−1

@@ -214,13 +214,23 @@ applyDataOpt oi n args

214-- Run-time: do everything

215

216instance Optimisable (TT Name) where

217+ applyOpts (P _ (NS (UN "plus") ["Nat","Prelude"]) _)

218+ = return (P Ref (UN "prim__addBigInt") Erased)

219+ applyOpts (P _ (NS (UN "mult") ["Nat","Prelude"]) _)

220+ = return (P Ref (UN "prim__mulBigInt") Erased)

221+ applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x)

222+ = applyOpts x

223+ applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _)

224+ = return (App (P Ref (NS (UN "id") ["Builtins"]) Erased) Erased)

225+ applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _)

226+ = return (App (P Ref (NS (UN "id") ["Builtins"]) Erased) Erased)

217 applyOpts c@(P (DCon t arity) n _)

227 applyOpts c@(P (DCon t arity) n _)

218 = do i <- getIState

228 = do i <- getIState

219 case lookupCtxt n (idris_optimisation i) of

229 case lookupCtxt n (idris_optimisation i) of

220 (oi:_) -> return $ applyDataOptRT oi n t arity []

230 (oi:_) -> return $ applyDataOptRT oi n t arity []

221 _ -> return c

231 _ -> return c

222 applyOpts t@(App f a)

232 applyOpts t@(App f a)

223− | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE

233+ | (c@(P (DCon t arity) n _), args) <- unApply t

224 = do args' <- mapM applyOpts args

234 = do args' <- mapM applyOpts args

225 i <- getIState

235 i <- getIState

226 case lookupCtxt n (idris_optimisation i) of

236 case lookupCtxt n (idris_optimisation i) of

@@ -266,6 +276,12 @@ applyDataOptRT oi n tag arity args

266 bind [] tm = tm

276 bind [] tm = tm

267 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

277 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

268

278

279+ -- Nat special cases

280+ -- TODO: Would be nice if this was configurable in idris source!

281+ doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0)

282+ doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

283+ = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

284+

269 doOpts n args True f = Erased

285 doOpts n args True f = Erased

270 doOpts n args _ forced

286 doOpts n args _ forced

271 = let args' = filter keep (zip (map (\x -> x `elem` forced) [0..])

287 = let args' = filter keep (zip (map (\x -> x `elem` forced) [0..])

src/Idris/IBC.hs+7−1

@@ -23,7 +23,7 @@ import Debug.Trace

23import Paths_idris

25ibcVersion :: Word8

26−ibcVersion = 38

26+ibcVersion = 39

28data IBCFile = IBCFile { ver :: Word8,

29 sourcefile :: FilePath,

@@ -714,6 +714,9 @@ instance Binary CaseAlt where

714 put x1

715 put x2

716 put x3

717+ SucCase x1 x2 -> do putWord8 4

718+ put x1

719+ put x2

717 get

720 get

718 = do i <- getWord8

721 = do i <- getWord8

719 case i of

722 case i of

@@ -731,6 +734,9 @@ instance Binary CaseAlt where

731 x2 <- get

734 x2 <- get

732 x3 <- get

735 x3 <- get

733 return (FnCase x1 x2 x3)

736 return (FnCase x1 x2 x3)

737+ 4 -> do x1 <- get

738+ x2 <- get

739+ return (SucCase x1 x2)

734 _ -> error "Corrupted binary data for CaseAlt"

740 _ -> error "Corrupted binary data for CaseAlt"

735

741

736instance Binary CaseDefs where

742instance Binary CaseDefs where