cdbfec9 · Idris-dev · git.iko.soy

src/IRTS/Bytecode.hs+1−1

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

8989 where getL (Loc x) = L x

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

9191bc reg SNothing r = NULL reg : clean r

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

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

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

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

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

src/IRTS/CodegenJava.hs+1−1

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

464464 mkIdrisObject conId args >>= ppExp pp

465465

466466-- 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

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

469469

470470-- Projections

src/IRTS/Compiler.hs+6−5

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

281281 x' <- irTerm vs env x

282282 t' <- irTerm vs env t

283283 e' <- irTerm vs env e

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

284+ return (LCase Shared x'

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

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

286287 ])

287288

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

510511irSC vs (ProjCase tm alts) = do

511512 tm' <- irTerm vs [] tm

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

513− return $ LCase tm' alts'

514+ return $ LCase Shared tm' alts'

514515

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

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

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

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

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

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

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

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

560561 where

561562 namesBoundIn :: LAlt -> [Name]

562563 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

588589 detag <- fgetState (opt_detaggable . ist_optimisation cn)

589590 if detag

590591 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

592593

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

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

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

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

599600

600601 -- 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

602603 where

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

604605 isDetaggable _ = return False

src/IRTS/Defunctionalise.hs+10−6

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

55

66import IRTS.Lang

77import Idris.Core.TT

8+import Idris.Core.CaseTree

89

910import Debug.Trace

1011import Data.Maybe

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

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

1920 | DProj DExp Int

2021 | DC Int Name [DExp]

21− | DCase DExp [DAlt]

22+ | DCase CaseType DExp [DAlt]

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

2324 | DConst Const

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

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

105106 return $ DProj (DUpdate n t') i

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

107108 return $ DProj t' i

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

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

110− return $ DCase e' alts'

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

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

111+ return $ DCase up e' alts'

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

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

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

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

161162

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

163164 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)

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

166167 nec (DConstCase _ e) = needsEval x e

167168 nec (DDefaultCase e) = needsEval x e

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

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

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

266267 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" ++

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

270+ where update = case up of

271+ Shared -> " "

272+ Updatable -> "! "

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

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

271275 show' env (DConst c) = show c

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

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

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

3232 prefixCallNamespacesExp name (SUpdate var e) =

3333 SUpdate var (prefixCallNamespacesExp name e)

34− prefixCallNamespacesExp name (SCase var alts) =

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

34+ prefixCallNamespacesExp name (SCase up var alts) =

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

3636 prefixCallNamespacesExp name (SChkCase var alts) =

3737 SChkCase var (map (prefixCallNamespacesCase name) alts)

3838 prefixCallNamespacesExp _ exp = exp

src/IRTS/Lang.hs+15−11

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

11module IRTS.Lang where

22

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

4−import Idris.Core.TT

5−import Data.List

6−import Debug.Trace

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

4+import Idris.Core.TT

5+import Idris.Core.CaseTree

6+import Data.List

7+import Debug.Trace

78

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

910

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

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

2021 | LProj LExp Int -- projection

2122 | LCon Int Name [LExp]

22− | LCase LExp [LAlt]

23+ | LCase CaseType LExp [LAlt]

2324 | LConst Const

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

2526 | LOp PrimFn [LExp]

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

170171 return (LProj t' i)

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

172173 return (LCon i n args')

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

174− e' <- lift env e

175− return (LCase e' alts')

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

175+ e' <- lift env e

176+ return (LCase up e' alts')

176177 where

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

178179 return (LConCase i n args e')

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

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

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

208209usedIn 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

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

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

212213 usedInA env (LDefaultCase e) = usedIn env e

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

240241 show' env ind (LCon i n args)

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

242243

243− show' env ind (LCase e alts)

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

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

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

245246 where

247+ update = case up of

248+ Shared -> " "

249+ Updatable -> "! "

246250 fmt [] = ""

247251 fmt [alt]

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

src/IRTS/Simplified.hs+10−9

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

22

33import IRTS.Defunctionalise

44import Idris.Core.TT

5+import Idris.Core.CaseTree

56import Idris.Core.Typecheck

67import Data.Maybe

78import Control.Monad.State

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

1617 | SLet LVar SExp SExp

1718 | SUpdate LVar SExp

1819 | SCon Int Name [LVar]

19− | SCase LVar [SAlt]

20+ | SCase CaseType LVar [SAlt]

2021 | SChkCase LVar [SAlt]

2122 | SProj LVar Int

2223 | SConst Const

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

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

6970 (Glob x, Just e) ->

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

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

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

73− case v of

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

75− (Glob x, Just e) ->

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

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

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

74+ case v of

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

76+ (Glob x, Just e) ->

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

7778simplify tl (DChkCase e alts)

7879 = do v <- sVar e

7980 alts' <- mapM (sAlt tl) alts

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

173174 sc env (SProj e i)

174175 = do e' <- scVar env e

175176 return (SProj e' i)

176− sc env (SCase e alts)

177+ sc env (SCase up e alts)

177178 = do e' <- scVar env e

178179 alts' <- mapM (scalt env) alts

179− return (SCase e' alts')

180+ return (SCase up e' alts')

180181 sc env (SChkCase e alts)

181182 = do e' <- scVar env e

182183 alts' <- mapM (scalt env) alts

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

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

4242!-}

4343

4444data CaseType = Updatable | Shared

45− deriving (Eq, Ord)

45+ deriving (Eq, Ord, Show)

4646

4747type SC = SC' Term

4848