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

git.iko.soy/Idris-dev

Fix overenthuiastic unused argument removal problem

(Wasn't checking case analysis where the scrutinee was the result of a projection)

commit64fc0430179df32d2672943128a19b97c7368b28 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateThu 15 Nov 2012, 12:33 (14 years ago) parent2616a69

3 files changed+10−5

compare with master

unifiedsplit

src/Core/CaseTree.hs+1 src/Core/Evaluate.hs+4−2 src/IRTS/CodegenC.hs+5−3

src/Core/CaseTree.hs+1

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

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

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

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

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

147148 nu' (STerm t) = directUse t

148149 nu' _ = []

149150

src/Core/Evaluate.hs+4−2

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

175175 ev ntimes (n:stk) True env tm

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

177177 return $ VP nt n vty

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

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

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

179180 if canSimplify inl inr n stk

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

181182 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

244245 = traceWhen traceon (show stk) $

245246 do let val = lookupDefAcc Nothing n atRepl ctxt

246247 case val of

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

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

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

248250 if canSimplify inl inr n stk

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

250252 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

4242 hClose tmph

4343 let useclang = False

4444 comp <- getCC

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

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

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

4746 gccDbg dbg ++

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

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

4849 " " ++ tmpn ++

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

5051 " -o " ++ out

52+-- putStrLn gcc

5153 exit <- system gcc

5254 when (exit /= ExitSuccess) $

5355 putStrLn ("FAILURE: " ++ gcc)

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

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

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

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

279−doOp v LNoOp args = ""

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

280282doOp _ _ _ = "FAIL"