cdbfec9 · Idris-dev · git.iko.soy

src/IRTS/Bytecode.hs+1−1

compare with master

unifiedsplit

@@ -89,7 +89,7 @@ bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r

89 where getL (Loc x) = L x

90bc reg (SError str) r = [ERROR str]

91bc reg SNothing r = NULL reg : clean r

92−bc reg (SCase (Loc l) alts) r

92+bc reg (SCase up (Loc l) alts) r

93 | isConst alts = constCase reg (L l) alts r

94 | otherwise = conCase True reg (L l) alts r

95bc reg (SChkCase (Loc l) alts) r

src/IRTS/CodegenJava.hs+1−1

@@ -464,7 +464,7 @@ mkExp pp (SCon conId _ args) =

464 mkIdrisObject conId args >>= ppExp pp

465

466-- Case expressions

467−mkExp pp (SCase var alts) = mkCase pp True var alts

467+mkExp pp (SCase up var alts) = mkCase pp True var alts

468mkExp pp (SChkCase var alts) = mkCase pp False var alts

469

470-- Projections

src/IRTS/Compiler.hs+6−5

@@ -281,7 +281,8 @@ irTerm vs env tm@(App f a) = case unApply tm of

281 x' <- irTerm vs env x

282 t' <- irTerm vs env t

283 e' <- irTerm vs env e

284+ return (LCase Shared x'

284− return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'

285+ [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'

285 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'

286 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'

286 ])

287 ])

287

288

@@ -510,7 +511,7 @@ irSC vs (UnmatchedCase str) = return $ LError str

510irSC vs (ProjCase tm alts) = do

511irSC vs (ProjCase tm alts) = do

511 tm' <- irTerm vs [] tm

512 tm' <- irTerm vs [] tm

512 alts' <- mapM (irAlt vs tm') alts

513 alts' <- mapM (irAlt vs tm') alts

513− return $ LCase tm' alts'

514+ return $ LCase Shared tm' alts'

514

515

515-- Transform matching on Delay to applications of Force.

516-- Transform matching on Delay to applications of Force.

516irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])

517irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])

@@ -556,7 +557,7 @@ irSC vs (Case up n [alt]) = do

556 alt' <- irAlt vs (LV (Glob n)) alt

557 alt' <- irAlt vs (LV (Glob n)) alt

557 return $ case namesBoundIn alt' `usedIn` subexpr alt' of

558 return $ case namesBoundIn alt' `usedIn` subexpr alt' of

558 [] -> subexpr alt' -- strip the unused top-most case

559 [] -> subexpr alt' -- strip the unused top-most case

559− _ -> LCase (LV (Glob n)) [alt']

560+ _ -> LCase up (LV (Glob n)) [alt']

560 where

561 where

561 namesBoundIn :: LAlt -> [Name]

562 namesBoundIn :: LAlt -> [Name]

562 namesBoundIn (LConCase cn i ns sc) = ns

563 namesBoundIn (LConCase cn i ns sc) = ns

@@ -588,7 +589,7 @@ irSC vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do

588 detag <- fgetState (opt_detaggable . ist_optimisation cn)

589 detag <- fgetState (opt_detaggable . ist_optimisation cn)

589 if detag

590 if detag

590 then irSC vs (Case up n [ConCase cn a ns sc])

591 then irSC vs (Case up n [ConCase cn a ns sc])

591− else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

592+ else LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

592

593

593irSC vs sc@(Case up n alts) = do

594irSC vs sc@(Case up n alts) = do

594 -- check that neither alternative needs the newtype optimisation,

595 -- check that neither alternative needs the newtype optimisation,

@@ -598,7 +599,7 @@ irSC vs sc@(Case up n alts) = do

598 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)

599 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)

599

600

600 -- everything okay

601 -- everything okay

601− LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

602+ LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

602 where

603 where

603 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn

604 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn

604 isDetaggable _ = return False

605 isDetaggable _ = return False

src/IRTS/Defunctionalise.hs+10−6

@@ -5,6 +5,7 @@ module IRTS.Defunctionalise(module IRTS.Defunctionalise,

5

6import IRTS.Lang

7import Idris.Core.TT

8+import Idris.Core.CaseTree

8

9

9import Debug.Trace

10import Debug.Trace

10import Data.Maybe

11import Data.Maybe

@@ -18,7 +19,7 @@ data DExp = DV LVar

18 | DUpdate Name DExp -- eval expression, then update var with it

19 | DUpdate Name DExp -- eval expression, then update var with it

19 | DProj DExp Int

20 | DProj DExp Int

20 | DC Int Name [DExp]

21 | DC Int Name [DExp]

21− | DCase DExp [DAlt]

22+ | DCase CaseType DExp [DAlt]

22 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)

23 | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)

23 | DConst Const

24 | DConst Const

24 | DForeign FLang FType String [(FType, DExp)]

25 | DForeign FLang FType String [(FType, DExp)]

@@ -105,9 +106,9 @@ addApps defs (n, LFun _ _ args e)

105 return $ DProj (DUpdate n t') i

106 return $ DProj (DUpdate n t') i

106 aa env (LProj t i) = do t' <- aa env t

107 aa env (LProj t i) = do t' <- aa env t

107 return $ DProj t' i

108 return $ DProj t' i

108− aa env (LCase e alts) = do e' <- aa env e

109+ aa env (LCase up e alts) = do e' <- aa env e

109− alts' <- mapM (aaAlt env) alts

110+ alts' <- mapM (aaAlt env) alts

110− return $ DCase e' alts'

111+ return $ DCase up e' alts'

111 aa env (LConst c) = return $ DConst c

112 aa env (LConst c) = return $ DConst c

112 aa env (LForeign l t n args) = liftM (DForeign l t n) (mapM (aaF env) args)

113 aa env (LForeign l t n args) = liftM (DForeign l t n) (mapM (aaF env) args)

113 aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)

114 aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)

@@ -161,7 +162,7 @@ addApps defs (n, LFun _ _ args e)

161

162

162 needsEval x (DApp _ _ args) = or (map (needsEval x) args)

163 needsEval x (DApp _ _ args) = or (map (needsEval x) args)

163 needsEval x (DC _ _ args) = or (map (needsEval x) args)

164 needsEval x (DC _ _ args) = or (map (needsEval x) args)

164− needsEval x (DCase e alts) = needsEval x e || or (map nec alts)

165+ needsEval x (DCase up e alts) = needsEval x e || or (map nec alts)

165 where nec (DConCase _ _ _ e) = needsEval x e

166 where nec (DConCase _ _ _ e) = needsEval x e

166 nec (DConstCase _ e) = needsEval x e

167 nec (DConstCase _ e) = needsEval x e

167 nec (DDefaultCase e) = needsEval x e

168 nec (DDefaultCase e) = needsEval x e

@@ -264,8 +265,11 @@ instance Show DExp where

264 show' env (DUpdate n e) = "!update " ++ show n ++ "(" ++ show' env e ++ ")"

265 show' env (DUpdate n e) = "!update " ++ show n ++ "(" ++ show' env e ++ ")"

265 show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

266 show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

266 show' env (DProj t i) = show t ++ "!" ++ show i

267 show' env (DProj t i) = show t ++ "!" ++ show i

267− show' env (DCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++

268+ show' env (DCase up e alts) = "case" ++ update ++ show' env e ++ " of {\n\t" ++

268 showSep "\n\t| " (map (showAlt env) alts)

269 showSep "\n\t| " (map (showAlt env) alts)

270+ where update = case up of

271+ Shared -> " "

272+ Updatable -> "! "

269 show' env (DChkCase e alts) = "case' " ++ show' env e ++ " of {\n\t" ++

273 show' env (DChkCase e alts) = "case' " ++ show' env e ++ " of {\n\t" ++

270 showSep "\n\t| " (map (showAlt env) alts)

274 showSep "\n\t| " (map (showAlt env) alts)

271 show' env (DConst c) = show c

275 show' env (DConst c) = show c

src/IRTS/Java/Mangling.hs+2−2

@@ -31,8 +31,8 @@ prefixCallNamespaces name (SFun fname args i e) =

31 SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)

32 prefixCallNamespacesExp name (SUpdate var e) =

33 SUpdate var (prefixCallNamespacesExp name e)

34− prefixCallNamespacesExp name (SCase var alts) =

34+ prefixCallNamespacesExp name (SCase up var alts) =

35− SCase var (map (prefixCallNamespacesCase name) alts)

35+ SCase up var (map (prefixCallNamespacesCase name) alts)

36 prefixCallNamespacesExp name (SChkCase var alts) =

37 SChkCase var (map (prefixCallNamespacesCase name) alts)

38 prefixCallNamespacesExp _ exp = exp

src/IRTS/Lang.hs+15−11

@@ -1,9 +1,10 @@

1module IRTS.Lang where

2

3−import Control.Monad.State hiding (lift)

3+import Control.Monad.State hiding (lift)

4−import Idris.Core.TT

4+import Idris.Core.TT

5+import Idris.Core.CaseTree

5−import Data.List

6+import Data.List

6−import Debug.Trace

7+import Debug.Trace

7

8

8data Endianness = Native | BE | LE deriving (Show, Eq)

9data Endianness = Native | BE | LE deriving (Show, Eq)

9

10

@@ -19,7 +20,7 @@ data LExp = LV LVar

19 | LLam [Name] LExp -- lambda, lifted out before compiling

20 | LLam [Name] LExp -- lambda, lifted out before compiling

20 | LProj LExp Int -- projection

21 | LProj LExp Int -- projection

21 | LCon Int Name [LExp]

22 | LCon Int Name [LExp]

22− | LCase LExp [LAlt]

23+ | LCase CaseType LExp [LAlt]

23 | LConst Const

24 | LConst Const

24 | LForeign FLang FType String [(FType, LExp)]

25 | LForeign FLang FType String [(FType, LExp)]

25 | LOp PrimFn [LExp]

26 | LOp PrimFn [LExp]

@@ -170,9 +171,9 @@ lift env (LProj t i) = do t' <- lift env t

170 return (LProj t' i)

171 return (LProj t' i)

171lift env (LCon i n args) = do args' <- mapM (lift env) args

172lift env (LCon i n args) = do args' <- mapM (lift env) args

172 return (LCon i n args')

173 return (LCon i n args')

173−lift env (LCase e alts) = do alts' <- mapM liftA alts

174+lift env (LCase up e alts) = do alts' <- mapM liftA alts

174− e' <- lift env e

175+ e' <- lift env e

175− return (LCase e' alts')

176+ return (LCase up e' alts')

176 where

177 where

177 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e

178 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e

178 return (LConCase i n args e')

179 return (LConCase i n args e')

@@ -206,7 +207,7 @@ usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

206usedIn env (LLam ns e) = usedIn (env \\ ns) e

207usedIn env (LLam ns e) = usedIn (env \\ ns) e

207usedIn env (LCon i n args) = concatMap (usedIn env) args

208usedIn env (LCon i n args) = concatMap (usedIn env) args

208usedIn env (LProj t i) = usedIn env t

209usedIn env (LProj t i) = usedIn env t

209−usedIn env (LCase e alts) = usedIn env e ++ concatMap (usedInA env) alts

210+usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

210 where usedInA env (LConCase i n ns e) = usedIn env e

211 where usedInA env (LConCase i n ns e) = usedIn env e

211 usedInA env (LConstCase c e) = usedIn env e

212 usedInA env (LConstCase c e) = usedIn env e

212 usedInA env (LDefaultCase e) = usedIn env e

213 usedInA env (LDefaultCase e) = usedIn env e

@@ -240,9 +241,12 @@ instance Show LExp where

240 show' env ind (LCon i n args)

241 show' env ind (LCon i n args)

241 = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

242 = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

242

243

243− show' env ind (LCase e alts)

244+ show' env ind (LCase up e alts)

244− = "case " ++ show' env ind e ++ " of \n" ++ fmt alts

245+ = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts

245 where

246 where

247+ update = case up of

248+ Shared -> " "

249+ Updatable -> "! "

246 fmt [] = ""

250 fmt [] = ""

247 fmt [alt]

251 fmt [alt]

248 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

252 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

src/IRTS/Simplified.hs+10−9

@@ -2,6 +2,7 @@ module IRTS.Simplified where

2

3import IRTS.Defunctionalise

4import Idris.Core.TT

5+import Idris.Core.CaseTree

5import Idris.Core.Typecheck

6import Idris.Core.Typecheck

6import Data.Maybe

7import Data.Maybe

7import Control.Monad.State

8import Control.Monad.State

@@ -16,7 +17,7 @@ data SExp = SV LVar

16 | SLet LVar SExp SExp

17 | SLet LVar SExp SExp

17 | SUpdate LVar SExp

18 | SUpdate LVar SExp

18 | SCon Int Name [LVar]

19 | SCon Int Name [LVar]

19− | SCase LVar [SAlt]

20+ | SCase CaseType LVar [SAlt]

20 | SChkCase LVar [SAlt]

21 | SChkCase LVar [SAlt]

21 | SProj LVar Int

22 | SProj LVar Int

22 | SConst Const

23 | SConst Const

@@ -68,12 +69,12 @@ simplify tl (DProj t i) = do v <- sVar t

68 (x, Nothing) -> return (SProj x i)

69 (x, Nothing) -> return (SProj x i)

69 (Glob x, Just e) ->

70 (Glob x, Just e) ->

70 return (SLet (Glob x) e (SProj (Glob x) i))

71 return (SLet (Glob x) e (SProj (Glob x) i))

71−simplify tl (DCase e alts) = do v <- sVar e

72+simplify tl (DCase up e alts) = do v <- sVar e

72− alts' <- mapM (sAlt tl) alts

73+ alts' <- mapM (sAlt tl) alts

73− case v of

74+ case v of

74− (x, Nothing) -> return (SCase x alts')

75+ (x, Nothing) -> return (SCase up x alts')

75− (Glob x, Just e) ->

76+ (Glob x, Just e) ->

76− return (SLet (Glob x) e (SCase (Glob x) alts'))

77+ return (SLet (Glob x) e (SCase up (Glob x) alts'))

77simplify tl (DChkCase e alts)

78simplify tl (DChkCase e alts)

78 = do v <- sVar e

79 = do v <- sVar e

79 alts' <- mapM (sAlt tl) alts

80 alts' <- mapM (sAlt tl) alts

@@ -173,10 +174,10 @@ scopecheck fn ctxt envTop tm = sc envTop tm where

173 sc env (SProj e i)

174 sc env (SProj e i)

174 = do e' <- scVar env e

175 = do e' <- scVar env e

175 return (SProj e' i)

176 return (SProj e' i)

176− sc env (SCase e alts)

177+ sc env (SCase up e alts)

177 = do e' <- scVar env e

178 = do e' <- scVar env e

178 alts' <- mapM (scalt env) alts

179 alts' <- mapM (scalt env) alts

179− return (SCase e' alts')

180+ return (SCase up e' alts')

180 sc env (SChkCase e alts)

181 sc env (SChkCase e alts)

181 = do e' <- scVar env e

182 = do e' <- scVar env e

182 alts' <- mapM (scalt env) alts

183 alts' <- mapM (scalt env) alts

src/Idris/Core/CaseTree.hs+1−1

@@ -42,7 +42,7 @@ deriving instance NFData SC'

42!-}

43

44data CaseType = Updatable | Shared

45− deriving (Eq, Ord)

45+ deriving (Eq, Ord, Show)

46

47type SC = SC' Term

48