7282c0a · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Some optimisation of case trees

7282c0aEdwin Brady9 years ago

libs/prelude/IO.idr+1−1

compare with master

unifiedsplit

@@ -101,7 +101,7 @@ unsafePerformPrimIO : PrimIO a -> a

101prim_io_pure : a -> PrimIO a

102prim_io_pure x = Prim__IO x

103

104−-- %inline

104+-- Don't %inline; the compiler treats it specially

105io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

106io_bind (MkIO fn)

107 = \k => MkIO (\w => prim_io_bind (fn w)

src/IRTS/CodegenC.hs+7−1

@@ -220,8 +220,14 @@ bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show l

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

221bcc i (PROJECTINTO r t idx)

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

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

224+ = indent i ++ showCode i alt

225+ where

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

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

228+ indent i ++ "}\n"

223bcc i (CASE True r code def)

229bcc i (CASE True r code def)

224− | length code < 4 && length code > 0 = showCase i def code

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

225 where

231 where

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

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

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

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

src/IRTS/JavaScript/PrimOp.hs−2

@@ -26,8 +26,6 @@ data JsPrimTy = PTBool | PTAny deriving (Eq, Ord)

26type PrimF = [JsExpr] -> JsExpr

27type PrimDec = (Bool, JsPrimTy, PrimF) -- the bool indicates if bigint library is used or not

29−deriving instance Ord PrimFn

30−

31primDB :: Map.Map PrimFn PrimDec

29primDB :: Map.Map PrimFn PrimDec

32primDB =

30primDB =

33 Map.fromList [

31 Map.fromList [

src/IRTS/Lang.hs+95−33

@@ -15,7 +15,8 @@ import Idris.Core.TT

16import Control.Monad.State hiding (lift)

17import Data.Data (Data)

18−import Data.List

18+import Data.List

19+import qualified Data.Map.Strict as Map

19import Data.Typeable (Typeable)

20import Data.Typeable (Typeable)

20import GHC.Generics (Generic)

21import GHC.Generics (Generic)

@@ -44,26 +45,26 @@ data LExp = LV Name

44 | LOp PrimFn [LExp]

45 | LOp PrimFn [LExp]

45 | LNothing

46 | LNothing

46 | LError String

47 | LError String

47− deriving Eq

48+ deriving (Eq, Ord)

49data FDesc = FCon Name

50data FDesc = FCon Name

50 | FStr String

51 | FStr String

51 | FUnknown

52 | FUnknown

52 | FIO FDesc

53 | FIO FDesc

53 | FApp Name [FDesc]

54 | FApp Name [FDesc]

54− deriving (Show, Eq)

55+ deriving (Show, Eq, Ord)

56data Export = ExportData FDesc -- Exported data descriptor (usually string)

57data Export = ExportData FDesc -- Exported data descriptor (usually string)

57 | ExportFun Name -- Idris name

58 | ExportFun Name -- Idris name

58 FDesc -- Exported function descriptor

59 FDesc -- Exported function descriptor

59 FDesc -- Return type descriptor

60 FDesc -- Return type descriptor

60 [FDesc] -- Argument types

61 [FDesc] -- Argument types

61− deriving (Show, Eq)

62+ deriving (Show, Eq, Ord)

63data ExportIFace = Export Name -- FFI descriptor

64data ExportIFace = Export Name -- FFI descriptor

64 String -- interface file

65 String -- interface file

65 [Export]

66 [Export]

66− deriving (Show, Eq)

67+ deriving (Show, Eq, Ord)

68-- Primitive operators. Backends are not *required* to implement all

69-- Primitive operators. Backends are not *required* to implement all

69-- of these, but should report an error if they are unable

70-- of these, but should report an error if they are unable

@@ -96,12 +97,12 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy

96 | LCrash

97 | LCrash

98 | LNoOp

99 | LNoOp

99− deriving (Show, Eq, Generic)

100+ deriving (Show, Eq, Ord, Generic)

100

101

101-- Supported target languages for foreign calls

102-- Supported target languages for foreign calls

102

103

103data FCallType = FStatic | FObject | FConstructor

104data FCallType = FStatic | FObject | FConstructor

104− deriving (Show, Eq)

105+ deriving (Show, Eq, Ord)

105

106

106data FType = FArith ArithTy

107data FType = FArith ArithTy

107 | FFunction

108 | FFunction

@@ -112,24 +113,24 @@ data FType = FArith ArithTy

112 | FManagedPtr

113 | FManagedPtr

113 | FCData

114 | FCData

114 | FAny

115 | FAny

115− deriving (Show, Eq)

116+ deriving (Show, Eq, Ord)

116

117

117-- FIXME: Why not use this for all the IRs now?

118-- FIXME: Why not use this for all the IRs now?

118data LAlt' e = LConCase Int Name [Name] e

119data LAlt' e = LConCase Int Name [Name] e

119 | LConstCase Const e

120 | LConstCase Const e

120 | LDefaultCase e

121 | LDefaultCase e

121− deriving (Show, Eq, Functor, Data, Typeable)

122+ deriving (Show, Eq, Ord, Functor, Data, Typeable)

122

123

123type LAlt = LAlt' LExp

124type LAlt = LAlt' LExp

124

125

125data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def

126data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def

126 | LConstructor Name Int Int -- constructor name, tag, arity

127 | LConstructor Name Int Int -- constructor name, tag, arity

127− deriving (Show, Eq)

128+ deriving (Show, Eq, Ord)

128

129

129type LDefs = Ctxt LDecl

130type LDefs = Ctxt LDecl

130

131

131data LOpt = Inline | NoInline

132data LOpt = Inline | NoInline

132− deriving (Show, Eq)

133+ deriving (Show, Eq, Ord)

133

134

134addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])

135addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])

135addTags i ds = tag i ds []

136addTags i ds = tag i ds []

@@ -140,37 +141,71 @@ addTags i ds = tag i ds []

140 tag i (x : as) acc = tag i as (x : acc)

141 tag i (x : as) acc = tag i as (x : acc)

141 tag i [] acc = (i, reverse acc)

142 tag i [] acc = (i, reverse acc)

142

143

143−data LiftState = LS Name Int [(Name, LDecl)]

144+data LiftState = LS (Maybe Name) Int [(Name, LDecl)]

145+ (Map.Map ([Name], LExp) Name) -- map from args/expressions

146+ -- to names, so we don't create the same function

147+ -- multiple times

148+

149+setBaseName :: Name -> State LiftState ()

150+setBaseName n

151+ = do LS _ i ds done <- get

152+ put (LS (Just n) i ds done)

144

153

145lname (NS n x) i = NS (lname n i) x

154lname (NS n x) i = NS (lname n i) x

146lname (UN n) i = MN i n

155lname (UN n) i = MN i n

147lname x i = sMN i (showCG x ++ "_lam")

156lname x i = sMN i (showCG x ++ "_lam")

148

157

149−liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

150−liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

151−

152−lambdaLift :: Name -> LDecl -> [(Name, LDecl)]

153−lambdaLift n (LFun opts _ args e)

154− = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in

155− (n, LFun opts n args e') : decls

156−lambdaLift n x = [(n, x)]

157−

158getNextName :: State LiftState Name

159−getNextName = do LS n i ds <- get

159+getNextName

160+ = do LS mn i ds done <- get

161+ let newn = case mn of

162+ Nothing -> lname (sUN "_") i

163+ Just n -> lname n i

160− put (LS n (i + 1) ds)

164+ put (LS mn (i + 1) ds done)

161− return (lname n i)

165+ return newn

166+

167+renameArgs :: [Name] -> LExp -> ([Name], LExp)

168+renameArgs args e

169+ = let newargNames = map (\i -> sMN i "lift") [0..]

170+ newargs = zip args newargNames in

171+ (map snd newargs, rename newargs e)

162

172

163addFn :: Name -> LDecl -> State LiftState ()

173addFn :: Name -> LDecl -> State LiftState ()

164−addFn fn d = do LS n i ds <- get

174+addFn fn d

175+ = do LS n i ds done <- get

176+ put (LS n i ((fn, d) : ds) done)

177+

178+makeFn :: [Name] -> LExp -> State LiftState Name

179+makeFn args exp

180+ = do fn <- getNextName

181+ let (args', exp') = renameArgs args exp

182+ LS n i ds done <- get

183+ case Map.lookup (args', exp') done of

184+ Just fn -> return fn

185+ Nothing ->

186+ do addFn fn (LFun [Inline] fn args' exp')

187+ LS n i ds done <- get

165− put (LS n i ((fn, d) : ds))

188+ put (LS n i ds (Map.insert (args', exp') fn done))

189+ return fn

190+

191+liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

192+liftAll xs =

193+ let (LS _ _ decls _) = execState (mapM_ liftDef xs) (LS Nothing 0 [] Map.empty) in

194+ decls

195+

196+liftDef :: (Name, LDecl) -> State LiftState ()

197+liftDef (n, LFun opts _ args e) =

198+ do setBaseName n

199+ e' <- lift args e

200+ addFn n (LFun opts n args e')

201+liftDef (n, x) = addFn n x

166

202

167lift :: [Name] -> LExp -> State LiftState LExp

203lift :: [Name] -> LExp -> State LiftState LExp

168lift env (LV v) = return (LV v) -- Lifting happens before these can exist...

204lift env (LV v) = return (LV v) -- Lifting happens before these can exist...

169lift env (LApp tc (LV n) args) = do args' <- mapM (lift env) args

205lift env (LApp tc (LV n) args) = do args' <- mapM (lift env) args

170 return (LApp tc (LV n) args')

206 return (LApp tc (LV n) args')

171lift env (LApp tc f args) = do f' <- lift env f

207lift env (LApp tc f args) = do f' <- lift env f

172− fn <- getNextName

208+ fn <- makeFn env f'

173− addFn fn (LFun [Inline] fn env f')

174 args' <- mapM (lift env) args

209 args' <- mapM (lift env) args

175 return (LApp tc (LV fn) (map LV env ++ args'))

210 return (LApp tc (LV fn) (map LV env ++ args'))

176lift env (LLazyApp n args) = do args' <- mapM (lift env) args

211lift env (LLazyApp n args) = do args' <- mapM (lift env) args

@@ -180,8 +215,7 @@ lift env (LLazyExp (LConst c)) = return (LConst c)

180-- = lift env (LLazyApp f args)

215-- = lift env (LLazyApp f args)

181lift env (LLazyExp e) = do e' <- lift env e

216lift env (LLazyExp e) = do e' <- lift env e

182 let usedArgs = nub $ usedIn env e'

217 let usedArgs = nub $ usedIn env e'

183− fn <- getNextName

218+ fn <- makeFn usedArgs e'

184− addFn fn (LFun [NoInline] fn usedArgs e')

185 return (LLazyApp fn (map LV usedArgs))

219 return (LLazyApp fn (map LV usedArgs))

186lift env (LForce e) = do e' <- lift env e

220lift env (LForce e) = do e' <- lift env e

187 return (LForce e')

221 return (LForce e')

@@ -190,8 +224,7 @@ lift env (LLet n v e) = do v' <- lift env v

190 return (LLet n v' e')

224 return (LLet n v' e')

191lift env (LLam args e) = do e' <- lift (env ++ args) e

225lift env (LLam args e) = do e' <- lift (env ++ args) e

192 let usedArgs = nub $ usedIn env e'

226 let usedArgs = nub $ usedIn env e'

193− fn <- getNextName

194− addFn fn (LFun [Inline] fn (usedArgs ++ args) e')

227+ fn <- makeFn (usedArgs ++ args) e'

195 return (LApp False (LV fn) (map LV usedArgs))

228 return (LApp False (LV fn) (map LV usedArgs))

196lift env (LProj t i) = do t' <- lift env t

229lift env (LProj t i) = do t' <- lift env t

197 return (LProj t' i)

230 return (LProj t' i)

@@ -329,6 +362,35 @@ lsubst n new (LCase t e alts) = let e' = lsubst n new e

329 LCase t e' alts'

362 LCase t e' alts'

330lsubst n new tm = tm

363lsubst n new tm = tm

331

364

365+rename :: [(Name, Name)] -> LExp -> LExp

366+rename ns tm@(LV x)

367+ = case lookup x ns of

368+ Just n -> LV n

369+ _ -> tm

370+rename ns (LApp t e args)

371+ = let e' = rename ns e

372+ args' = map (rename ns) args in

373+ LApp t e' args'

374+rename ns (LLazyApp fn args)

375+ = let args' = map (rename ns) args in

376+ LLazyApp fn args'

377+rename ns (LLazyExp e) = LLazyExp (rename ns e)

378+rename ns (LForce e) = LForce (rename ns e)

379+rename ns (LLet v val sc) = LLet v (rename ns val) (rename ns sc)

380+rename ns (LLam args sc) = LLam args (rename ns sc)

381+rename ns (LProj e i) = LProj (rename ns e) i

382+rename ns (LCon lv t cn args) = let args' = map (rename ns) args in

383+ LCon lv t cn args'

384+rename ns (LOp op args) = let args' = map (rename ns) args in

385+ LOp op args'

386+rename ns (LForeign fd rd args)

387+ = let args' = map (\(d, a) -> (d, rename ns a)) args in

388+ LForeign fd rd args'

389+rename ns (LCase t e alts) = let e' = rename ns e

390+ alts' = map (fmap (rename ns)) alts in

391+ LCase t e' alts'

392+rename ns tm = tm

393+

332instance Show LExp where

394instance Show LExp where

333 show e = show' [] "" e where

395 show e = show' [] "" e where

334 show' env ind (LV n) = show n

396 show' env ind (LV n) = show n

@@ -357,7 +419,7 @@ instance Show LExp where

357 atloc (Just l) = "@" ++ show (LV l) ++ ":"

419 atloc (Just l) = "@" ++ show (LV l) ++ ":"

358

420

359 show' env ind (LCase up e alts)

421 show' env ind (LCase up e alts)

360− = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts

422+ = "case" ++ update ++ "(" ++ show' env ind e ++ ") of \n" ++ fmt alts

361 where

423 where

362 update = case up of

424 update = case up of

363 Shared -> " "

425 Shared -> " "

src/IRTS/LangOpts.hs+104−6

@@ -35,13 +35,21 @@ nextN = do i <- get

35doInline :: LDefs -> LDecl -> LDecl

36doInline defs d@(LConstructor _ _ _) = d

37doInline defs (LFun opts topn args exp)

38− = let res = evalState (eval [] initEnv [topn] defs exp)

38+ = let inl = evalState (eval [] initEnv [topn] defs exp)

39− (length args) in

39+ (length args)

40−-- = let res = evalState (inlineWith [topn] (map (\n -> (n, LV n)) args) exp) 0 in

40+ -- do some case floating, which might arise as a result

41+ res = caseFloats 10 inl in

41 case res of

42 case res of

42 LLam args' body -> LFun opts topn (map snd initNames ++ args') body

43 LLam args' body -> LFun opts topn (map snd initNames ++ args') body

43 _ -> LFun opts topn (map snd initNames) res

44 _ -> LFun opts topn (map snd initNames) res

44 where

45 where

46+ caseFloats 0 tm = tm

47+ caseFloats n tm

48+ = let res = caseFloat tm in

49+ if res == tm

50+ then res

51+ else caseFloats (n-1) res

52+

45 initNames = zipWith (\n i -> (n, newn n i)) args [0..]

53 initNames = zipWith (\n i -> (n, newn n i)) args [0..]

46 initEnv = map (\(n, n') -> (n, LV n')) initNames

54 initEnv = map (\(n, n') -> (n, LV n')) initNames

47 newn (UN n) i = MN i n

55 newn (UN n) i = MN i n

@@ -61,7 +69,11 @@ eval :: [LExp] -> [(Name, LExp)] -> [Name] -> LDefs -> LExp -> State Int LExp

61eval stk env rec defs (LLazyApp n es)

69eval stk env rec defs (LLazyApp n es)

62 = unload stk <$> LLazyApp n <$> (mapM (eval [] env rec defs) es)

70 = unload stk <$> LLazyApp n <$> (mapM (eval [] env rec defs) es)

63eval stk env rec defs (LForce e)

71eval stk env rec defs (LForce e)

64− = unload stk <$> LForce <$> eval [] env rec defs e

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

73+ case e' of

74+ LLazyExp forced -> return $ unload stk forced

75+ LLazyApp n es -> return $ unload stk (LApp False (LV n) es)

76+ _ -> return (unload stk (LForce e'))

65eval stk env rec defs (LLazyExp e)

77eval stk env rec defs (LLazyExp e)

66 = unload stk <$> LLazyExp <$> eval [] env rec defs e

78 = unload stk <$> LLazyExp <$> eval [] env rec defs e

67-- Special case for io_bind, because it needs to keep executing the first

79-- Special case for io_bind, because it needs to keep executing the first

@@ -98,9 +110,10 @@ eval stk env rec defs (LCase ty e alts)

98 -- If they're all lambdas, bind the lambda at the top

110 -- If they're all lambdas, bind the lambda at the top

99 let prefix = getLams (map getRHS alts')

111 let prefix = getLams (map getRHS alts')

100 case prefix of

112 case prefix of

101− [] -> return $ LCase ty e' alts'

113+ [] -> return $ LCase ty e' (replaceInAlts e' alts')

102 args -> do alts_red <- mapM (dropArgs args) alts'

114 args -> do alts_red <- mapM (dropArgs args) alts'

103− return $ LLam args (LCase ty e' alts_red)

115+ return $ LLam args

116+ (LCase ty e' (replaceInAlts e' alts_red))

104eval stk env rec defs (LOp f es)

117eval stk env rec defs (LOp f es)

105 = unload stk <$> LOp f <$> mapM (eval [] env rec defs) es

118 = unload stk <$> LOp f <$> mapM (eval [] env rec defs) es

106eval stk env rec defs (LForeign t s args)

119eval stk env rec defs (LForeign t s args)

@@ -129,6 +142,8 @@ eval stk env rec defs var@(LV n)

129 Just (LFun opts _ args body) <- lookupCtxtExact n defs,

142 Just (LFun opts _ args body) <- lookupCtxtExact n defs,

130 Inline `elem` opts ->

143 Inline `elem` opts ->

131 apply stk env (n : rec) defs var args body

144 apply stk env (n : rec) defs var args body

145+ | Just (LConstructor n t a) <- lookupCtxtExact n defs ->

146+ return (LCon Nothing t n stk)

132 | otherwise -> return (unload stk var)

147 | otherwise -> return (unload stk var)

133eval stk env rec defs t = return (unload stk t)

148eval stk env rec defs t = return (unload stk t)

134

149

@@ -156,6 +171,89 @@ dropArgs as (LDefaultCase (LLam args rhs))

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

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

157 return (LDefaultCase rhs')

172 return (LDefaultCase rhs')

158

173

174+caseFloat :: LExp -> LExp

175+caseFloat (LApp tc e es) = LApp tc (caseFloat e) (map caseFloat es)

176+caseFloat (LForce e) = LForce (caseFloat e)

177+caseFloat (LCon up i n es) = LCon up i n (map caseFloat es)

178+caseFloat (LOp f es) = LOp f (map caseFloat es)

179+caseFloat (LLam ns sc) = LLam ns (caseFloat sc)

180+caseFloat (LLet v val sc) = LLet v (caseFloat val) (caseFloat sc)

181+caseFloat (LCase _ (LCase ct exp alts) alts')

182+ | all conRHS alts || length alts == 1

183+ = replaceInCase (LCase ct (caseFloat exp) (map (updateWith alts') alts))

184+ where

185+ conRHS (LConCase _ _ _ (LCon _ _ _ _)) = True

186+ conRHS (LConstCase _ (LCon _ _ _ _)) = True

187+ conRHS (LDefaultCase (LCon _ _ _ _)) = True

188+ conRHS _ = False

189+

190+ updateWith alts (LConCase i n es rhs) =

191+ LConCase i n es (caseFloat (conOpt (LCase Shared (caseFloat rhs) alts)))

192+ updateWith alts (LConstCase c rhs) =

193+ LConstCase c (caseFloat (conOpt (LCase Shared (caseFloat rhs) alts)))

194+ updateWith alts (LDefaultCase rhs) =

195+ LDefaultCase (caseFloat (conOpt (LCase Shared (caseFloat rhs) alts)))

196+

197+ conOpt (LCase ct (LCon _ t n args) alts)

198+ = pickAlt n args alts

199+ conOpt tm = tm

200+

201+ pickAlt n args (LConCase i n' es rhs : as) | n == n'

202+ = substAll (zip es args) rhs

203+ pickAlt _ _ (LDefaultCase rhs : as) = rhs

204+ pickAlt n args (_ : as) = pickAlt n args as

205+ pickAlt n args [] = error "Can't happen pickAlt - impossible case found"

206+

207+ substAll [] rhs = rhs

208+ substAll ((n, tm) : ss) rhs = lsubst n tm (substAll ss rhs)

209+

210+caseFloat (LCase ct exp alts')

211+ = replaceInCase (LCase ct (caseFloat exp) (map cfAlt alts'))

212+ where

213+ cfAlt (LConCase i n es rhs) = LConCase i n es (caseFloat rhs)

214+ cfAlt (LConstCase c rhs) = LConstCase c (caseFloat rhs)

215+ cfAlt (LDefaultCase rhs) = LDefaultCase (caseFloat rhs)

216+caseFloat exp = exp

217+

218+replaceInCase :: LExp -> LExp

219+replaceInCase (LCase ty e alts)

220+ = LCase ty e (replaceInAlts e alts)

221+replaceInCase exp = exp

222+

223+replaceInAlts :: LExp -> [LAlt] -> [LAlt]

224+replaceInAlts exp alts = dropDups $ concatMap (replaceInAlt exp) alts

225+

226+-- Drop overlapping case (arising from case merging of overlapping

227+-- patterns)

228+dropDups (alt@(LConCase _ i n ns) : alts)

229+ = alt : dropDups (filter (notTag i) alts)

230+ where

231+ notTag i (LConCase _ j n ns) = i /= j

232+ notTag _ _ = True

233+dropDups (c : alts) = c : dropDups alts

234+dropDups [] = []

235+

236+

237+replaceInAlt :: LExp -> LAlt -> [LAlt]

238+-- In an alternative, if the case appears on the right hand side, replace

239+-- it with the given expression, to preserve sharing

240+replaceInAlt exp@(LV _) (LConCase i con args rhs)

241+ = [LConCase i con args $

242+ replaceExp (LCon Nothing i con (map LV args)) exp rhs]

243+-- if a default case inspects the same variable as the case it's in,

244+-- remove the inspection and replace with the alternatives

245+-- (i.e. merge the inner case block)

246+replaceInAlt exp@(LV var) (LDefaultCase (LCase ty (LV var') alts))

247+ | var == var' = alts

248+replaceInAlt exp a = [a]

249+

250+replaceExp :: LExp -> LExp -> LExp -> LExp

251+replaceExp (LCon _ t n args) new (LCon _ t' n' args')

252+ | n == n' && args == args' = new

253+replaceExp (LCon _ t n args) new (LApp _ (LV n') args')

254+ | n == n' && args == args' = new

255+replaceExp old new tm = tm

256+

159-- dropArgs as (LConstCase c rhs) = LConstCase c (dropRHS as rhs)

257-- dropArgs as (LConstCase c rhs) = LConstCase c (dropRHS as rhs)

160-- dropArgs as (LDefaultCase rhs) = LDefaultCase (dropRHS as rhs)

258-- dropArgs as (LDefaultCase rhs) = LDefaultCase (dropRHS as rhs)

161

259