63944aa · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Simplify LV/DV constructor be removing unused case

`LV` and `DV` were always called with a `Glob` construtor for the `LVar` datatype. We eliminate this indirection.

commit63944aad79ee1f6819273e7877061dc51c060818 authorThomas Scholtes <thomas-scholtes@gmx.de> dateSat 12 Aug 2017, 13:48 (9 years ago) parent83b1bed

7 files changed+70−74

compare with master

unifiedsplit

src/IRTS/Compiler.hs+13−13 src/IRTS/Defunctionalise.hs+23−24 src/IRTS/JavaScript/Codegen.hs+5−5 src/IRTS/JavaScript/LangTransforms.hs+2−2 src/IRTS/Lang.hs+15−16 src/IRTS/LangOpts.hs+9−9 src/IRTS/Simplified.hs+3−5

src/IRTS/Compiler.hs+13−13

@@ -214,7 +214,7 @@ build (n, d)

214214 Just (ar, op) ->

215215 let args = map (\x -> sMN x "op") [0..] in

216216 return (n, (LFun [] n (take ar args)

217− (LOp op (map (LV . Glob) (take ar args)))))

217+ (LOp op (map LV (take ar args)))))

218218 _ -> do def <- mkLDecl n d

219219 logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

220220 return (n, def)

@@ -398,7 +398,7 @@ irTerm top vs env tm@(App _ f a) = do

398398 -> irTerm top vs env (head argsPruned)

399399

400400 | otherwise -- not newtype, plain data ctor

401− -> buildApp (LV $ Glob n) argsPruned

401+ -> buildApp (LV n) argsPruned

402402

403403 -- not saturated, underapplied

404404 LT | isNewtype -- newtype

@@ -407,11 +407,11 @@ irTerm top vs env tm@(App _ f a) = do

407407 <$> irTerm top vs env (head argsPruned)

408408

409409 | isNewtype -- newtype but the value is not among args yet

410− -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]

410+ -> return . padLams $ \[vn] -> LApp False (LV n) [LV vn]

411411

412412 -- not a newtype, just apply to a constructor

413413 | otherwise

414− -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned

414+ -> padLams . applyToNames <$> buildApp (LV n) argsPruned

415415

416416 -- type constructor

417417 (P (TCon t a) n _, args) -> return LNothing

@@ -446,7 +446,7 @@ irTerm top vs env tm@(App _ f a) = do

446446

447447 applyToNames :: LExp -> [Name] -> LExp

448448 applyToNames tm [] = tm

449− applyToNames tm ns = LApp False tm $ map (LV . Glob) ns

449+ applyToNames tm ns = LApp False tm $ map LV ns

450450

451451 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp

452452 padLambdas used startIdx endSIdx mkTerm

@@ -457,7 +457,7 @@ irTerm top vs env tm@(App _ f a) = do

457457

458458 applyName :: Name -> IState -> [Term] -> Idris LExp

459459 applyName n ist args =

460− LApp False (LV $ Glob n) <$> mapM (irTerm top vs env . erase) (zip [0..] args)

460+ LApp False (LV n) <$> mapM (irTerm top vs env . erase) (zip [0..] args)

461461 where

462462 erase (i, x)

463463 | i >= arity || i `elem` used = x

@@ -479,9 +479,9 @@ irTerm top vs env tm@(App _ f a) = do

479479 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)

480480 fst4 (x,_,_,_,_,_) = x

481481

482−irTerm top vs env (P _ n _) = return $ LV (Glob n)

482+irTerm top vs env (P _ n _) = return $ LV n

483483irTerm top vs env (V i)

484− | i >= 0 && i < length env = return $ LV (Glob (env!!i))

484+ | i >= 0 && i < length env = return $ LV (env!!i)

485485 | otherwise = ifail $ "bad de bruijn index: " ++ show i

486486

487487irTerm top vs env (Bind n (Lam _ _) sc) = LLam [n'] <$> irTerm top vs (n':env) sc

@@ -546,7 +546,7 @@ irSC top vs (ProjCase tm alts) = do

546546irSC top vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])

547547 | delay == txt "Delay"

548548 = do sc' <- irSC top vs sc -- mkForce n' n sc

549− return $ lsubst n' (LForce (LV (Glob n))) sc'

549+ return $ lsubst n' (LForce (LV n)) sc'

550550

551551-- There are two transformations in this case:

552552--

@@ -583,10 +583,10 @@ irSC top vs (Case up n [alt]) = do

583583 case replacement of

584584 Just sc -> irSC top vs sc

585585 _ -> do

586− alt' <- irAlt top vs (LV (Glob n)) alt

586+ alt' <- irAlt top vs (LV n) alt

587587 return $ case namesBoundIn alt' `usedIn` subexpr alt' of

588588 [] -> subexpr alt' -- strip the unused top-most case

589− _ -> LCase up (LV (Glob n)) [alt']

589+ _ -> LCase up (LV n) [alt']

590590 where

591591 namesBoundIn :: LAlt -> [Name]

592592 namesBoundIn (LConCase cn i ns sc) = ns

@@ -618,7 +618,7 @@ irSC top vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do

618618 detag <- fgetState (opt_detaggable . ist_optimisation cn)

619619 if detag

620620 then irSC top vs (Case up n [ConCase cn a ns sc])

621− else LCase up (LV (Glob n)) <$> mapM (irAlt top vs (LV (Glob n))) alts

621+ else LCase up (LV n) <$> mapM (irAlt top vs (LV n)) alts

622622

623623irSC top vs sc@(Case up n alts) = do

624624 -- check that neither alternative needs the newtype optimisation,

@@ -628,7 +628,7 @@ irSC top vs sc@(Case up n alts) = do

628628 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)

629629

630630 -- everything okay

631− LCase up (LV (Glob n)) <$> mapM (irAlt top vs (LV (Glob n))) alts

631+ LCase up (LV n) <$> mapM (irAlt top vs (LV n)) alts

632632 where

633633 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn

634634 isDetaggable _ = return False

src/IRTS/Defunctionalise.hs+23−24

@@ -34,12 +34,12 @@ import Data.List

3434import Data.Maybe

3535import Debug.Trace

3636

37−data DExp = DV LVar

37+data DExp = DV Name

3838 | DApp Bool Name [DExp] -- True = tail call

3939 | DLet Name DExp DExp -- name just for pretty printing

4040 | DUpdate Name DExp -- eval expression, then update var with it

4141 | DProj DExp Int

42− | DC (Maybe LVar) Int Name [DExp]

42+ | DC (Maybe Name) Int Name [DExp]

4343 | DCase CaseType DExp [DAlt]

4444 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)

4545 | DConst Const

@@ -90,27 +90,27 @@ addApps defs (n, LFun _ _ args e)

9090 return (n, DFun n args e')

9191 where

9292 aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp

93− aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)

94− | otherwise = aa env (LApp False (LV (Glob n)) [])

95− aa env (LApp tc (LV (Glob n)) args)

93+ aa env (LV n) | n `elem` env = return $ DV n

94+ | otherwise = aa env (LApp False (LV n) [])

95+ aa env (LApp tc (LV n) args)

9696 = do args' <- mapM (aa env) args

9797 case lookupCtxtExact n defs of

9898 Just (LConstructor _ i ar) -> return $ DApp tc n args'

9999 Just (LFun _ _ as _) -> let arity = length as in

100100 fixApply tc n args' arity

101− Nothing -> return $ chainAPPLY (DV (Glob n)) args'

101+ Nothing -> return $ chainAPPLY (DV n) args'

102102 aa env (LLazyApp n args)

103103 = do args' <- mapM (aa env) args

104104 case lookupCtxtExact n defs of

105105 Just (LConstructor _ i ar) -> return $ DApp False n args'

106106 Just (LFun _ _ as _) -> let arity = length as in

107107 fixLazyApply n args' arity

108− Nothing -> return $ chainAPPLY (DV (Glob n)) args'

109− aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args)

108+ Nothing -> return $ chainAPPLY (DV n) args'

109+ aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV n) args)

110110 aa env (LForce e) = liftM eEVAL (aa env e)

111111 aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)

112112 aa env (LCon loc i n args) = liftM (DC loc i n) (mapM (aa env) args)

113− aa env (LProj t@(LV (Glob n)) i)

113+ aa env (LProj t@(LV n) i)

114114 | n `elem` env = do t' <- aa env t

115115 return $ DProj (DUpdate n t') i

116116 aa env (LProj t i) = do t' <- aa env t

@@ -170,7 +170,7 @@ addApps defs (n, LFun _ _ args e)

170170

171171 preEval [] t = t

172172 preEval (x : xs) t

173− | needsEval x t = DLet x (DV (Glob x)) (preEval xs t)

173+ | needsEval x t = DLet x (DV x) (preEval xs t)

174174 | otherwise = preEval xs t

175175

176176 needsEval x (DApp _ _ args) = any (needsEval x) args

@@ -188,7 +188,7 @@ addApps defs (n, LFun _ _ args e)

188188 | otherwise = needsEval x v || needsEval x e

189189 needsEval x (DForeign _ _ args) = any (needsEval x) (map snd args)

190190 needsEval x (DOp op args) = any (needsEval x) args

191− needsEval x (DProj (DV (Glob x')) _) = x == x'

191+ needsEval x (DProj (DV x') _) = x == x'

192192 needsEval x _ = False

193193

194194eEVAL x = DApp False (sMN 0 "EVAL") [x]

@@ -207,7 +207,7 @@ toCons ns (n, i)

207207 EvalCase (\tlarg ->

208208 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

209209 (dupdate tlarg

210− (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

210+ (DApp False n (map DV (take i (genArgs 0))))))))

211211 : [] -- mkApplyCase n 0 i

212212 | otherwise = []

213213 where dupdate tlarg x = DUpdate tlarg x

@@ -219,7 +219,7 @@ toConsA ns (n, i)

219219-- EvalCase (\tlarg ->

220220-- (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

221221-- (dupdate tlarg

222−-- (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

222+-- (DApp False n (map DV (take i (genArgs 0))))))))

223223 = mkApplyCase n ar i

224224 | otherwise = []

225225 where dupdate tlarg x = x

@@ -229,13 +229,13 @@ mkApplyCase fname n ar

229229 = let nm = mkUnderCon fname (ar - n) in

230230 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))

231231 (DApp False (mkUnderCon fname (ar - (n + 1)))

232− (map (DV . Glob) (take n (genArgs 0) ++

232+ (map DV (take n (genArgs 0) ++

233233 [sMN 0 "arg"])))))

234234 :

235235 if (ar - (n + 2) >=0 )

236236 then (nm, n, Apply2Case (DConCase (-1) nm (take n (genArgs 0))

237237 (DApp False (mkUnderCon fname (ar - (n + 2)))

238− (map (DV . Glob) (take n (genArgs 0) ++

238+ (map DV (take n (genArgs 0) ++

239239 [sMN 0 "arg0", sMN 0 "arg1"])))))

240240 :

241241 mkApplyCase fname (n + 1) ar

@@ -243,9 +243,9 @@ mkApplyCase fname n ar

243243

244244mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

245245mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"]

246− (mkBigCase (sMN 0 "EVAL") 256 (DV (Glob (sMN 0 "arg")))

246+ (mkBigCase (sMN 0 "EVAL") 256 (DV (sMN 0 "arg"))

247247 (mapMaybe evalCase xs ++

248− [DDefaultCase (DV (Glob (sMN 0 "arg")))])))

248+ [DDefaultCase (DV (sMN 0 "arg"))])))

249249 where

250250 evalCase (n, t, EvalCase x) = Just (x (sMN 0 "arg"))

251251 evalCase _ = Nothing

@@ -256,7 +256,7 @@ mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"]

256256 [] -> DNothing

257257 cases ->

258258 mkBigCase (sMN 0 "APPLY") 256

259− (DV (Glob (sMN 0 "fn")))

259+ (DV (sMN 0 "fn"))

260260 (cases ++

261261 [DDefaultCase DNothing])))

262262 where

@@ -269,14 +269,14 @@ mkApply2 xs = (sMN 0 "APPLY2", DFun (sMN 0 "APPLY2") [sMN 0 "fn", sMN 0 "arg0",

269269 [] -> DNothing

270270 cases ->

271271 mkBigCase (sMN 0 "APPLY") 256

272− (DV (Glob (sMN 0 "fn")))

272+ (DV (sMN 0 "fn"))

273273 (cases ++

274274 [DDefaultCase

275275 (DApp False (sMN 0 "APPLY")

276276 [DApp False (sMN 0 "APPLY")

277− [DV (Glob (sMN 0 "fn")),

278− DV (Glob (sMN 0 "arg0"))],

279− DV (Glob (sMN 0 "arg1"))])

277+ [DV (sMN 0 "fn"),

278+ DV (sMN 0 "arg0")],

279+ DV (sMN 0 "arg1")])

280280 ])))

281281 where

282282 applyCase (n, t, Apply2Case x) = Just x

@@ -297,8 +297,7 @@ mkUnderCon n missing = sMN missing ("U_" ++ show n)

297297

298298instance Show DExp where

299299 show e = show' [] e where

300− show' env (DV (Loc i)) = "var " ++ env!!i

301− show' env (DV (Glob n)) = "GLOB " ++ show n

300+ show' env (DV n) = show n

302301 show' env (DApp _ e args) = show e ++ "(" ++

303302 showSep ", " (map (show' env) args) ++")"

304303 show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

src/IRTS/JavaScript/Codegen.hs+5−5

@@ -345,15 +345,15 @@ cgBody rt expr =

345345 expr -> cgBody' rt expr

346346

347347cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)

348−cgBody' rt (LV (Glob n)) =

348+cgBody' rt (LV n) =

349349 do

350350 argsFn <- getArgList n

351351 case argsFn of

352− Just a -> cgBody' rt (LApp False (LV (Glob n)) [])

352+ Just a -> cgBody' rt (LApp False (LV n) [])

353353 Nothing -> do

354354 n' <- cgName n

355355 pure $ ([], addRT rt n')

356−cgBody' rt (LApp tailcall (LV (Glob fn)) args) =

356+cgBody' rt (LApp tailcall (LV fn) args) =

357357 do

358358 let fname = jsName fn

359359 st <- get

@@ -372,10 +372,10 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =

372372 app <- formApp fn argVals

373373 pure (preDecs, addRT rt app)

374374

375−cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)

375+cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV n) args)

376376cgBody' rt (LLazyApp n args) =

377377 do

378− (d,v) <- cgBody ReturnBT (LApp False (LV (Glob n)) args)

378+ (d,v) <- cgBody ReturnBT (LApp False (LV n) args)

379379 pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)

380380cgBody' rt (LForce e) =

381381 do

src/IRTS/JavaScript/LangTransforms.hs+2−2

@@ -57,7 +57,7 @@ mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x

5757extractGlobs :: Map Name LDecl -> LDecl -> [Name]

5858extractGlobs defs (LConstructor _ _ _) = []

5959extractGlobs defs (LFun _ _ _ e) =

60− let f (LV (Glob x)) = Just x

60+ let f (LV x) = Just x

6161 f (LLazyApp x _) = Just x

6262 f _ = Nothing

6363 in [x | Just x <- map f $ universe e, Map.member x defs]

@@ -102,7 +102,7 @@ globlToCon x =

102102 transformBi (f x) x

103103 where

104104 f :: Map Name LDecl -> LExp -> LExp

105− f y x@(LV (Glob n)) =

105+ f y x@(LV n) =

106106 case Map.lookup n y of

107107 Just (LConstructor _ conId arity) -> LCon Nothing conId n []

108108 _ -> x

src/IRTS/Lang.hs+15−16

@@ -28,7 +28,7 @@ data LVar = Loc Int | Glob Name

2828

2929-- ASSUMPTION: All variable bindings have unique names here

3030-- Constructors commented as lifted are not present in the LIR provided to the different backends.

31−data LExp = LV LVar

31+data LExp = LV Name

3232 | LApp Bool LExp [LExp] -- True = tail call

3333 | LLazyApp Name [LExp] -- True = tail call

3434 | LLazyExp LExp -- lifted out before compiling

@@ -36,7 +36,7 @@ data LExp = LV LVar

3636 | LLet Name LExp LExp -- name just for pretty printing

3737 | LLam [Name] LExp -- lambda, lifted out before compiling

3838 | LProj LExp Int -- projection

39− | LCon (Maybe LVar) -- Location to reallocate, if available

39+ | LCon (Maybe Name) -- Location to reallocate, if available

4040 Int Name [LExp]

4141 | LCase CaseType LExp [LAlt]

4242 | LConst Const

@@ -168,13 +168,13 @@ addFn fn d = do LS n i ds <- get

168168

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

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

171−lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args

172− return (LApp tc (LV (Glob n)) args')

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

172+ return (LApp tc (LV n) args')

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

174174 fn <- getNextName

175175 addFn fn (LFun [Inline] fn env f')

176176 args' <- mapM (lift env) args

177− return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))

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

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

179179 return (LLazyApp n args')

180180lift env (LLazyExp (LConst c)) = return (LConst c)

@@ -184,7 +184,7 @@ lift env (LLazyExp e) = do e' <- lift env e

184184 let usedArgs = nub $ usedIn env e'

185185 fn <- getNextName

186186 addFn fn (LFun [NoInline] fn usedArgs e')

187− return (LLazyApp fn (map (LV . Glob) usedArgs))

187+ return (LLazyApp fn (map LV usedArgs))

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

189189 return (LForce e')

190190lift env (LLet n v e) = do v' <- lift env v

@@ -194,7 +194,7 @@ lift env (LLam args e) = do e' <- lift (env ++ args) e

194194 let usedArgs = nub $ usedIn env e'

195195 fn <- getNextName

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

197− return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))

197+ return (LApp False (LV fn) (map LV usedArgs))

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

199199 return (LProj t' i)

200200lift env (LCon loc i n args) = do args' <- mapM (lift env) args

@@ -229,11 +229,11 @@ allocUnique defs (n, LFun opts fn args e)

229229 -- Keep track of 'updatable' names in the state, i.e. names whose heap

230230 -- entry may be reused, along with the arity which was there

231231 findUp :: LExp -> State [(Name, Int)] LExp

232− findUp (LApp t (LV (Glob n)) as)

232+ findUp (LApp t (LV n) as)

233233 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,

234234 ar == length as

235235 = findUp (LCon Nothing i n as)

236− findUp (LV (Glob n))

236+ findUp (LV n)

237237 | Just (LConstructor _ i 0) <- lookupCtxtExact n defs

238238 = return $ LCon Nothing i n [] -- nullary cons are global, no need to update

239239 findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as

@@ -253,7 +253,7 @@ allocUnique defs (n, LFun opts fn args e)

253253 = LForeign t s <$> mapM (\ (t, e) -> do e' <- findUp e

254254 return (t, e')) es

255255 findUp (LOp o es) = LOp o <$> mapM findUp es

256− findUp (LCase Updatable e@(LV (Glob n)) as)

256+ findUp (LCase Updatable e@(LV n) as)

257257 = LCase Updatable e <$> mapM (doUpAlt n) as

258258 findUp (LCase t e as)

259259 = LCase t <$> findUp e <*> mapM findUpAlt as

@@ -277,7 +277,7 @@ allocUnique defs (n, LFun opts fn args e)

277277

278278 findVar _ [] i = return Nothing

279279 findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)

280− return (Just (Glob n))

280+ return (Just n)

281281 findVar acc (n : ns) i = findVar (n : acc) ns i

282282

283283

@@ -287,7 +287,7 @@ usedArg env n | n `elem` env = [n]

287287 | otherwise = []

288288

289289usedIn :: [Name] -> LExp -> [Name]

290−usedIn env (LV (Glob n)) = usedArg env n

290+usedIn env (LV n) = usedArg env n

291291usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args

292292usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n

293293usedIn env (LLazyExp e) = usedIn env e

@@ -297,7 +297,7 @@ usedIn env (LLam ns e) = usedIn (env \\ ns) e

297297usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in

298298 case v of

299299 Nothing -> rest

300− Just (Glob n) -> usedArg env n ++ rest

300+ Just n -> usedArg env n ++ rest

301301usedIn env (LProj t i) = usedIn env t

302302usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

303303 where usedInA env (LConCase i n ns e) = usedIn env e

@@ -308,7 +308,7 @@ usedIn env (LOp f args) = concatMap (usedIn env) args

308308usedIn env _ = []

309309

310310lsubst :: Name -> LExp -> LExp -> LExp

311−lsubst n new (LV (Glob x)) | n == x = new

311+lsubst n new (LV x) | n == x = new

312312lsubst n new (LApp t e args) = let e' = lsubst n new e

313313 args' = map (lsubst n new) args in

314314 LApp t e' args'

@@ -333,8 +333,7 @@ lsubst n new tm = tm

333333

334334instance Show LExp where

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

336− show' env ind (LV (Loc i)) = env!!i

337− show' env ind (LV (Glob n)) = show n

336+ show' env ind (LV n) = show n

338337

339338 show' env ind (LLazyApp e args)

340339 = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"

src/IRTS/LangOpts.hs+9−9

@@ -35,14 +35,14 @@ nextN = do i <- get

3535doInline :: LDefs -> LDecl -> LDecl

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

3737doInline defs (LFun opts topn args exp)

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

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

3939 LFun opts topn args res

4040 where

4141 inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp

42− inlineWith done env var@(LV (Glob n))

43− = case lookup n env of

44− Just t -> return t

45− Nothing -> return var

42+ inlineWith done env var@(LV n)

43+ = case lookup n env of

44+ Just t -> return t

45+ Nothing -> return var

4646 inlineWith done env (LLazyApp n es) = LLazyApp n <$> (mapM (inlineWith done env) es)

4747 inlineWith done env (LForce e) = LForce <$> inlineWith done env e

4848 inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e

@@ -51,12 +51,12 @@ doInline defs (LFun opts topn args exp)

5151 inlineWith done env (LLet n val sc)

5252 = do n' <- nextN

5353 LLet n' <$> inlineWith done env val <*>

54− inlineWith done ((n, LV (Glob n')) : env) sc

54+ inlineWith done ((n, LV n') : env) sc

5555 inlineWith done env (LLam args sc)

5656 = do ns' <- mapM (\n -> do n' <- nextN

5757 return (n, n')) args

5858 LLam (map snd ns') <$>

59− inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) sc

59+ inlineWith done (map (\ (n,n') -> (n, LV n')) ns' ++ env) sc

6060 inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i

6161 inlineWith done env (LCon loc i n es)

6262 = LCon loc i n <$> mapM (inlineWith done env) es

@@ -64,7 +64,7 @@ doInline defs (LFun opts topn args exp)

6464 = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts

6565 inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es

6666 -- the interesting case!

67− inlineWith done env (LApp t (LV (Glob n)) es)

67+ inlineWith done env (LApp t (LV n) es)

6868 | n `notElem` done,

6969 [LFun opts _ args body] <- lookupCtxt n defs,

7070 Inline `elem` opts,

@@ -82,6 +82,6 @@ doInline defs (LFun opts topn args exp)

8282 = do ns' <- mapM (\n -> do n' <- nextN

8383 return (n, n')) es

8484 LConCase i n (map snd ns') <$>

85− inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) rhs

85+ inlineWith done (map (\ (n,n') -> (n, LV n')) ns' ++ env) rhs

8686 inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e

8787 inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e

src/IRTS/Simplified.hs+3−5

@@ -53,8 +53,7 @@ ldefs = do (l, h) <- get

5353-- The boolean parameter indicates whether the expression is at tail

5454-- call position.

5555simplify :: Bool -> DExp -> State (DDefs, Int) SExp

56−simplify tl (DV (Loc i)) = return (SV (Loc i))

57−simplify tl (DV (Glob x))

56+simplify tl (DV x)

5857 = do ctxt <- ldefs

5958 case lookupCtxtExact x ctxt of

6059 Just (DConstructor _ t 0) -> return $ SCon Nothing t x []

@@ -68,7 +67,7 @@ simplify tl (DLet n v e) = do v' <- simplify False v

6867 return (SLet (Glob n) v' e')

6968simplify tl (DUpdate n e) = do e' <- simplify False e

7069 return (SUpdate (Glob n) e')

71−simplify tl (DC loc i n args) = bindExprs args (SCon loc i n)

70+simplify tl (DC loc i n args) = bindExprs args (SCon (Glob <$> loc) i n)

7271simplify tl (DProj t i) = bindExpr t (\var -> SProj var i)

7372simplify tl (DCase up e alts)

7473 = do alts' <- mapM (sAlt tl) alts

@@ -97,12 +96,11 @@ bindExpr :: DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp

9796bindExpr e f = bindExprM e (return . f)

9897

9998bindExprM :: DExp -> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp

100−bindExprM (DV (Glob x)) f

99+bindExprM (DV x) f

101100 = do ctxt <- ldefs

102101 case lookupCtxtExact x ctxt of

103102 Just (DConstructor _ t 0) -> bindExprM (DC Nothing t x []) f

104103 _ -> f (Glob x)

105−bindExprM (DV var) f = f var

106104bindExprM e f =

107105 do e' <- simplify False e

108106 var <- freshVar