git.iko.soy/Idris-dev
on master help sign in
Ctor usage analysis roughly complete.
ccadc82Matus Tejiscak
src/IRTS/Compiler.hs+7
compare with master
unifiedsplit
@@ -27,6 +27,7 @@ import Idris.Core.CaseTree
27
27
28import Control.Monad.State
28import Control.Monad.State
29import Data.List
29import Data.List
30+import qualified Data.Map as M
30import System.Process
31import System.Process
31import System.IO
32import System.IO
32import System.Directory
33import System.Directory
@@ -43,6 +44,12 @@ compile codegen f tm
43 let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn
44 let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn
44 defsIn <- mkDecls tm (concat used)
45 defsIn <- mkDecls tm (concat used)
45 findUnusedArgs (concat used)
46 findUnusedArgs (concat used)
47+
48+ -- TODO: DEBUG-ONLY, remove
49+ ist <- getIState
50+ let usedCtorArgs = findUsed (tt_ctxt ist) (idris_callgraph ist) (concat used)
51+ iLOG $ "USED CTOR ARGS:\n" ++ unlines (map show . M.toList $ usedCtorArgs)
52+
46 maindef <- irMain tm
53 maindef <- irMain tm
47 objs <- getObjectFiles codegen
54 objs <- getObjectFiles codegen
48 libs <- getLibs codegen
55 libs <- getLibs codegen
src/Idris/Erasure.hs+24−8
@@ -2,6 +2,7 @@
2
2
3module Idris.Erasure
3module Idris.Erasure
4 ( findUnusedArgs
4 ( findUnusedArgs
5+ , findUsed
5 ) where
6 ) where
6
7
7import Idris.AbsSyntax
8import Idris.AbsSyntax
@@ -53,7 +54,7 @@ findUsed ctx cg = unionMap $ findUsedDef cg . getDef ctx
53 findUsedSC cg vars (UnmatchedCase msg) = M.empty
54 findUsedSC cg vars (UnmatchedCase msg) = M.empty
54 findUsedSC cg vars (Case n alts) = unionMap (findUsedAlt cg vars) alts
55 findUsedSC cg vars (Case n alts) = unionMap (findUsedAlt cg vars) alts
55 findUsedSC cg vars (ProjCase t alt) = findUsedAlt cg vars alt
56 findUsedSC cg vars (ProjCase t alt) = findUsedAlt cg vars alt
56− findUsedSC cg vars (STerm t) = unionMap lookUp $ findUsedTerm cg t
57+ findUsedSC cg vars (STerm t) = unionMap lookUp . S.toList $ findUsedTerm cg t
57 where
58 where
58 lookUp :: Name -> UseMap
59 lookUp :: Name -> UseMap
59 lookUp n = case M.lookup n vars of
60 lookUp n = case M.lookup n vars of
@@ -61,18 +62,33 @@ findUsed ctx cg = unionMap $ findUsedDef cg . getDef ctx
61 Nothing -> M.empty
62 Nothing -> M.empty
62
63
63 findUsedAlt :: Ctxt CGInfo -> PatvarMap -> CaseAlt -> UseMap
64 findUsedAlt :: Ctxt CGInfo -> PatvarMap -> CaseAlt -> UseMap
64− findUsedAlt cg vars (FnCase n ns sc) = findUsedAlt cg vars sc -- TODO: what's this?
65+ findUsedAlt cg vars (FnCase n ns sc) = findUsedSC cg vars sc -- TODO: what's this?
65− findUsedAlt cg vars (ConstCase c sc) = findUsedAlt cg vars sc
66+ findUsedAlt cg vars (ConstCase c sc) = findUsedSC cg vars sc
66− findUsedAlt cg vars (SucCase n sc) = findUsedAlt cg (M.insert n (error "put S here") vars) sc -- TODO
67+ findUsedAlt cg vars (SucCase n sc) = findUsedSC cg (M.insert n (error "put S here") vars) sc -- TODO
67− findUsedAlt cg vars (DefaultCase sc) = findUsedAlt cg vars sc
68+ findUsedAlt cg vars (DefaultCase sc) = findUsedSC cg vars sc
68− findUsedAlt cg vars (ConCase n cnt ns sc) = findUsedAlt cg (ns `u` vars) sc
69+ findUsedAlt cg vars (ConCase n cnt ns sc) = findUsedSC cg (ns `u` vars) sc
69 where
70 where
70 u :: [Name] -> PatvarMap -> PatvarMap
71 u :: [Name] -> PatvarMap -> PatvarMap
71 vs `u` pmap = M.fromList [(var, (n, i)) | (i, var) <- zip [0..] vs] `M.union` pmap
72 vs `u` pmap = M.fromList [(var, (n, i)) | (i, var) <- zip [0..] vs] `M.union` pmap
72
73
74+ -- Find used pattern variables in the given term.
73 findUsedTerm :: Ctxt CGInfo -> Term -> Set Name
75 findUsedTerm :: Ctxt CGInfo -> Term -> Set Name
74− findUsedTerm cg t = undefined
76+ findUsedTerm cg (P _ n _) = S.singleton n
75−
77+ findUsedTerm cg (Bind n (Let t v) body) = S.unions
78+ [ findUsedTerm cg v
79+ , S.delete n $ findUsedTerm cg body
80+ , findUsedTerm cg t ]
81+ findUsedTerm cg (Bind n b t) = S.unions
82+ [ findUsedTerm cg (binderTy b)
83+ , S.delete n $ findUsedTerm cg t ]
84+ findUsedTerm cg (Proj t i) = findUsedTerm cg t
85+ findUsedTerm cg t@(App _ _) | (P _ n _, args) <- unApply t
86+ = let unused = case lookupCtxt n cg of
87+ [cgi] -> unusedpos cgi
88+ _ -> []
89+ in S.unions [findUsedTerm cg arg | (i,arg) <- zip [0..] args, i `notElem` unused]
90+ findUsedTerm cg _ = S.empty
91+
76findUnusedArgs :: [Name] -> Idris ()
92findUnusedArgs :: [Name] -> Idris ()
77findUnusedArgs names = do
93findUnusedArgs names = do
78 cg <- idris_callgraph <$> getIState
94 cg <- idris_callgraph <$> getIState