git.iko.soy/Idris-dev
on master help sign in
Ctor usage analysis roughly complete.
commitccadc8297ac4818d41c8c8f08bc9bf294a1cdafa authorMatus Tejiscak <ziman@functor.sk> dateTue 17 Dec 2013, 14:29 (13 years ago) parenta4f3868
2 files changed+31−8
compare with master
unifiedsplit
src/IRTS/Compiler.hs+7 src/Idris/Erasure.hs+24−8
src/IRTS/Compiler.hs+7
@@ -27,6 +27,7 @@ import Idris.Core.CaseTree
2727
2828import Control.Monad.State
2929import Data.List
30+import qualified Data.Map as M
3031import System.Process
3132import System.IO
3233import System.Directory
@@ -43,6 +44,12 @@ compile codegen f tm
4344 let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn
4445 defsIn <- mkDecls tm (concat used)
4546 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+
4653 maindef <- irMain tm
4754 objs <- getObjectFiles codegen
4855 libs <- getLibs codegen
src/Idris/Erasure.hs+24−8
@@ -2,6 +2,7 @@
22
33module Idris.Erasure
44 ( findUnusedArgs
5+ , findUsed
56 ) where
67
78import Idris.AbsSyntax
@@ -53,7 +54,7 @@ findUsed ctx cg = unionMap $ findUsedDef cg . getDef ctx
5354 findUsedSC cg vars (UnmatchedCase msg) = M.empty
5455 findUsedSC cg vars (Case n alts) = unionMap (findUsedAlt cg vars) alts
5556 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
5758 where
5859 lookUp :: Name -> UseMap
5960 lookUp n = case M.lookup n vars of
@@ -61,18 +62,33 @@ findUsed ctx cg = unionMap $ findUsedDef cg . getDef ctx
6162 Nothing -> M.empty
6263
6364 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 (ConstCase c sc) = findUsedAlt 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 (DefaultCase sc) = findUsedAlt cg vars sc
68− findUsedAlt cg vars (ConCase n cnt ns sc) = findUsedAlt cg (ns `u` vars) sc
65+ findUsedAlt cg vars (FnCase n ns sc) = findUsedSC cg vars sc -- TODO: what's this?
66+ findUsedAlt cg vars (ConstCase c sc) = findUsedSC cg vars sc
67+ findUsedAlt cg vars (SucCase n sc) = findUsedSC cg (M.insert n (error "put S here") vars) sc -- TODO
68+ findUsedAlt cg vars (DefaultCase sc) = findUsedSC cg vars sc
69+ findUsedAlt cg vars (ConCase n cnt ns sc) = findUsedSC cg (ns `u` vars) sc
6970 where
7071 u :: [Name] -> PatvarMap -> PatvarMap
7172 vs `u` pmap = M.fromList [(var, (n, i)) | (i, var) <- zip [0..] vs] `M.union` pmap
7273
74+ -- Find used pattern variables in the given term.
7375 findUsedTerm :: Ctxt CGInfo -> Term -> Set Name
74− findUsedTerm cg t = undefined
75−
76+ findUsedTerm cg (P _ n _) = S.singleton n
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+
7692findUnusedArgs :: [Name] -> Idris ()
7793findUnusedArgs names = do
7894 cg <- idris_callgraph <$> getIState