@@ -16,6 +16,7 @@ import Idris.Core.TT
1616import Control.Monad.State hiding (lift)
1717import Data.Data (Data)
1818import Data.List
19+import qualified Data.Map.Strict as Map
1920import Data.Typeable (Typeable)
2021import GHC.Generics (Generic)
2122
@@ -44,26 +45,26 @@ data LExp = LV Name
4445 | LOp PrimFn [LExp]
4546 | LNothing
4647 | LError String
47− deriving Eq
48+ deriving (Eq, Ord)
4849
4950data FDesc = FCon Name
5051 | FStr String
5152 | FUnknown
5253 | FIO FDesc
5354 | FApp Name [FDesc]
54− deriving (Show, Eq)
55+ deriving (Show, Eq, Ord)
5556
5657data Export = ExportData FDesc -- Exported data descriptor (usually string)
5758 | ExportFun Name -- Idris name
5859 FDesc -- Exported function descriptor
5960 FDesc -- Return type descriptor
6061 [FDesc] -- Argument types
61− deriving (Show, Eq)
62+ deriving (Show, Eq, Ord)
6263
6364data ExportIFace = Export Name -- FFI descriptor
6465 String -- interface file
6566 [Export]
66− deriving (Show, Eq)
67+ deriving (Show, Eq, Ord)
6768
6869-- Primitive operators. Backends are not *required* to implement all
6970-- of these, but should report an error if they are unable
@@ -96,12 +97,12 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
9697 | LCrash
9798
9899 | LNoOp
99− deriving (Show, Eq, Generic)
100+ deriving (Show, Eq, Ord, Generic)
100101
101102-- Supported target languages for foreign calls
102103
103104data FCallType = FStatic | FObject | FConstructor
104− deriving (Show, Eq)
105+ deriving (Show, Eq, Ord)
105106
106107data FType = FArith ArithTy
107108 | FFunction
@@ -112,24 +113,24 @@ data FType = FArith ArithTy
112113 | FManagedPtr
113114 | FCData
114115 | FAny
115− deriving (Show, Eq)
116+ deriving (Show, Eq, Ord)
116117
117118-- FIXME: Why not use this for all the IRs now?
118119data LAlt' e = LConCase Int Name [Name] e
119120 | LConstCase Const e
120121 | LDefaultCase e
121− deriving (Show, Eq, Functor, Data, Typeable)
122+ deriving (Show, Eq, Ord, Functor, Data, Typeable)
122123
123124type LAlt = LAlt' LExp
124125
125126data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
126127 | LConstructor Name Int Int -- constructor name, tag, arity
127− deriving (Show, Eq)
128+ deriving (Show, Eq, Ord)
128129
129130type LDefs = Ctxt LDecl
130131
131132data LOpt = Inline | NoInline
132− deriving (Show, Eq)
133+ deriving (Show, Eq, Ord)
133134
134135addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
135136addTags i ds = tag i ds []
@@ -140,37 +141,71 @@ addTags i ds = tag i ds []
140141 tag i (x : as) acc = tag i as (x : acc)
141142 tag i [] acc = (i, reverse acc)
142143
143−data LiftState = LS Name Int [(Name, LDecl)]
144+data LiftState = LS (Maybe Name) Int [(Name, LDecl)]
145+ (Map.Map ([Name], LExp) Name) -- map from args/expressions
146+ -- to names, so we don't create the same function
147+ -- multiple times
148+
149+setBaseName :: Name -> State LiftState ()
150+setBaseName n
151+ = do LS _ i ds done <- get
152+ put (LS (Just n) i ds done)
144153
145154lname (NS n x) i = NS (lname n i) x
146155lname (UN n) i = MN i n
147156lname x i = sMN i (showCG x ++ "_lam")
148157
149−liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
150−liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
151−
152−lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
153−lambdaLift n (LFun opts _ args e)
154− = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
155− (n, LFun opts n args e') : decls
156−lambdaLift n x = [(n, x)]
157−
158158getNextName :: State LiftState Name
159−getNextName = do LS n i ds <- get
160− put (LS n (i + 1) ds)
161− return (lname n i)
159+getNextName
160+ = do LS mn i ds done <- get
161+ let newn = case mn of
162+ Nothing -> lname (sUN "_") i
163+ Just n -> lname n i
164+ put (LS mn (i + 1) ds done)
165+ return newn
166+
167+renameArgs :: [Name] -> LExp -> ([Name], LExp)
168+renameArgs args e
169+ = let newargNames = map (\i -> sMN i "lift") [0..]
170+ newargs = zip args newargNames in
171+ (map snd newargs, rename newargs e)
162172
163173addFn :: Name -> LDecl -> State LiftState ()
164−addFn fn d = do LS n i ds <- get
165− put (LS n i ((fn, d) : ds))
174+addFn fn d
175+ = do LS n i ds done <- get
176+ put (LS n i ((fn, d) : ds) done)
177+
178+makeFn :: [Name] -> LExp -> State LiftState Name
179+makeFn args exp
180+ = do fn <- getNextName
181+ let (args', exp') = renameArgs args exp
182+ LS n i ds done <- get
183+ case Map.lookup (args', exp') done of
184+ Just fn -> return fn
185+ Nothing ->
186+ do addFn fn (LFun [Inline] fn args' exp')
187+ LS n i ds done <- get
188+ put (LS n i ds (Map.insert (args', exp') fn done))
189+ return fn
190+
191+liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
192+liftAll xs =
193+ let (LS _ _ decls _) = execState (mapM_ liftDef xs) (LS Nothing 0 [] Map.empty) in
194+ decls
195+
196+liftDef :: (Name, LDecl) -> State LiftState ()
197+liftDef (n, LFun opts _ args e) =
198+ do setBaseName n
199+ e' <- lift args e
200+ addFn n (LFun opts n args e')
201+liftDef (n, x) = addFn n x
166202
167203lift :: [Name] -> LExp -> State LiftState LExp
168204lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
169205lift env (LApp tc (LV n) args) = do args' <- mapM (lift env) args
170206 return (LApp tc (LV n) args')
171207lift env (LApp tc f args) = do f' <- lift env f
172− fn <- getNextName
173− addFn fn (LFun [Inline] fn env f')
208+ fn <- makeFn env f'
174209 args' <- mapM (lift env) args
175210 return (LApp tc (LV fn) (map LV env ++ args'))
176211lift env (LLazyApp n args) = do args' <- mapM (lift env) args
@@ -180,18 +215,17 @@ lift env (LLazyExp (LConst c)) = return (LConst c)
180215-- = lift env (LLazyApp f args)
181216lift env (LLazyExp e) = do e' <- lift env e
182217 let usedArgs = nub $ usedIn env e'
183− fn <- getNextName
184− addFn fn (LFun [NoInline] fn usedArgs e')
218+ fn <- makeFn usedArgs e'
185219 return (LLazyApp fn (map LV usedArgs))
186220lift env (LForce e) = do e' <- lift env e
187221 return (LForce e')
188222lift env (LLet n v e) = do v' <- lift env v
189223 e' <- lift (env ++ [n]) e
190224 return (LLet n v' e')
225+lift env (LLam args (LLam args' e)) = lift env (LLam (args ++ args') e)
191226lift env (LLam args e) = do e' <- lift (env ++ args) e
192227 let usedArgs = nub $ usedIn env e'
193− fn <- getNextName
194− addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
228+ fn <- makeFn (usedArgs ++ args) e'
195229 return (LApp False (LV fn) (map LV usedArgs))
196230lift env (LProj t i) = do t' <- lift env t
197231 return (LProj t' i)
@@ -329,6 +363,35 @@ lsubst n new (LCase t e alts) = let e' = lsubst n new e
329363 LCase t e' alts'
330364lsubst n new tm = tm
331365
366+rename :: [(Name, Name)] -> LExp -> LExp
367+rename ns tm@(LV x)
368+ = case lookup x ns of
369+ Just n -> LV n
370+ _ -> tm
371+rename ns (LApp t e args)
372+ = let e' = rename ns e
373+ args' = map (rename ns) args in
374+ LApp t e' args'
375+rename ns (LLazyApp fn args)
376+ = let args' = map (rename ns) args in
377+ LLazyApp fn args'
378+rename ns (LLazyExp e) = LLazyExp (rename ns e)
379+rename ns (LForce e) = LForce (rename ns e)
380+rename ns (LLet v val sc) = LLet v (rename ns val) (rename ns sc)
381+rename ns (LLam args sc) = LLam args (rename ns sc)
382+rename ns (LProj e i) = LProj (rename ns e) i
383+rename ns (LCon lv t cn args) = let args' = map (rename ns) args in
384+ LCon lv t cn args'
385+rename ns (LOp op args) = let args' = map (rename ns) args in
386+ LOp op args'
387+rename ns (LForeign fd rd args)
388+ = let args' = map (\(d, a) -> (d, rename ns a)) args in
389+ LForeign fd rd args'
390+rename ns (LCase t e alts) = let e' = rename ns e
391+ alts' = map (fmap (rename ns)) alts in
392+ LCase t e' alts'
393+rename ns tm = tm
394+
332395instance Show LExp where
333396 show e = show' [] "" e where
334397 show' env ind (LV n) = show n
@@ -357,7 +420,7 @@ instance Show LExp where
357420 atloc (Just l) = "@" ++ show (LV l) ++ ":"
358421
359422 show' env ind (LCase up e alts)
360− = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts
423+ = "case" ++ update ++ "(" ++ show' env ind e ++ ") of \n" ++ fmt alts
361424 where
362425 update = case up of
363426 Shared -> " "