64fc043 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Fix overenthuiastic unused argument removal problem

64fc043Edwin Brady14 years ago

src/Core/CaseTree.hs+1

compare with master

unifiedsplit

@@ -144,6 +144,7 @@ directUse _ = []

144findUsedArgs :: SC -> [Name] -> [Name]

145findUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nub $ nu' sc) where

146 nu' (Case n alts) = n : concatMap nua alts

147+ nu' (ProjCase t alts) = directUse t ++ concatMap nua alts

147 nu' (STerm t) = directUse t

148 nu' (STerm t) = directUse t

148 nu' _ = []

149 nu' _ = []

149

150

src/Core/Evaluate.hs+4−2

@@ -175,7 +175,8 @@ eval traceon ctxt maxred ntimes genv tm opts = ev ntimes [] True [] tm where

175 ev ntimes (n:stk) True env tm

176 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

177 return $ VP nt n vty

178+ [(CaseOp inl inr _ _ _ [] tree _ _, acc)]

178− [(CaseOp inl inr _ _ _ [] tree _ _, Public)] -> -- unoptimised version

179+ | acc == Public || simpl -> -- unoptimised version

179 if canSimplify inl inr n stk

180 if canSimplify inl inr n stk

180 then liftM (VP Ref n) (ev ntimes stk top env ty)

181 then liftM (VP Ref n) (ev ntimes stk top env ty)

181 else do c <- evCase ntimes (n:stk) top env [] [] tree

182 else do c <- evCase ntimes (n:stk) top env [] [] tree

@@ -244,7 +245,8 @@ eval traceon ctxt maxred ntimes genv tm opts = ev ntimes [] True [] tm where

244 = traceWhen traceon (show stk) $

245 = traceWhen traceon (show stk) $

245 do let val = lookupDefAcc Nothing n atRepl ctxt

246 do let val = lookupDefAcc Nothing n atRepl ctxt

246 case val of

247 case val of

247− [(CaseOp inl inr _ _ _ ns tree _ _, Public)] ->

248+ [(CaseOp inl inr _ _ _ ns tree _ _, acc)]

249+ | acc == Public || simpl -> -- unoptimised version

248 if canSimplify inl inr n stk

250 if canSimplify inl inr n stk

249 then return $ unload env (VP Ref n ty) args

251 then return $ unload env (VP Ref n ty) args

250 else do c <- evCase ntimes (n:stk) top env ns args tree

252 else do c <- evCase ntimes (n:stk) top env ns args tree

src/IRTS/CodegenC.hs+5−3

@@ -42,12 +42,14 @@ codegenC defs out exec incs objs libs dbg

42 hClose tmph

43 let useclang = False

44 comp <- getCC

45− let gcc = comp ++ " -I. " ++ objs ++ " -x c " ++

45+ let gcc = comp ++ " " ++

46− (if (exec == Executable) then "" else " -c ") ++

47 gccDbg dbg ++

46 gccDbg dbg ++

47+ " -I. " ++ objs ++ " -x c " ++

48+ (if (exec == Executable) then "" else " -c ") ++

48 " " ++ tmpn ++

49 " " ++ tmpn ++

49 " `idris --link` `idris --include` " ++ libs ++

50 " `idris --link` `idris --include` " ++ libs ++

50 " -o " ++ out

51 " -o " ++ out

52+-- putStrLn gcc

51 exit <- system gcc

53 exit <- system gcc

52 when (exit /= ExitSuccess) $

54 when (exit /= ExitSuccess) $

53 putStrLn ("FAILURE: " ++ gcc)

55 putStrLn ("FAILURE: " ++ gcc)

@@ -276,5 +278,5 @@ doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

276doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

278doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

277doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

279doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

278doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

280doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

279−doOp v LNoOp args = ""

281+doOp v LNoOp args = v ++ creg (last args)

280doOp _ _ _ = "FAIL"

282doOp _ _ _ = "FAIL"