git.iko.soy/Idris-dev
on master help sign in
Fix allocation of big integers
449bb27Edwin Brady
rts/idris_gmp.c+26−19
compare with master
unifiedsplit
@@ -9,10 +9,11 @@ VAL MKBIGI(int val) {
9
9
10VAL MKBIGC(VM* vm, char* val) {
10VAL MKBIGC(VM* vm, char* val) {
11 mpz_t* bigint;
11 mpz_t* bigint;
12− // FIXME! what if GC happens after cl allocation?
12+
13− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
13+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
14− bigint = allocate(vm, sizeof(mpz_t), 0);
14+ sizeof(mpz_t), 0);
15−
15+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
16+
16 mpz_init(*bigint);
17 mpz_init(*bigint);
17 mpz_set_str(*bigint, val, 10);
18 mpz_set_str(*bigint, val, 10);
18
19
@@ -24,9 +25,9 @@ VAL MKBIGC(VM* vm, char* val) {
24
25
25VAL MKBIGM(VM* vm, void* big) {
26VAL MKBIGM(VM* vm, void* big) {
26 mpz_t* bigint;
27 mpz_t* bigint;
27− // FIXME! what if GC happens after cl allocation?
28− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
28+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
29− bigint = allocate(vm, sizeof(mpz_t), 0);
29+ sizeof(mpz_t), 0);
30+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
30
31
31 mpz_init(*bigint);
32 mpz_init(*bigint);
32 mpz_set(*bigint, *((mpz_t*)big));
33 mpz_set(*bigint, *((mpz_t*)big));
@@ -39,8 +40,9 @@ VAL MKBIGM(VM* vm, void* big) {
39
40
40VAL MKBIGMc(VM* vm, void* big) {
41VAL MKBIGMc(VM* vm, void* big) {
41 mpz_t* bigint;
42 mpz_t* bigint;
42− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 1);
43+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
43− bigint = allocate(vm, sizeof(mpz_t), 1);
44+ sizeof(mpz_t), 0);
45+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
44
46
45 mpz_init(*bigint);
47 mpz_init(*bigint);
46 mpz_set(*bigint, *((mpz_t*)big));
48 mpz_set(*bigint, *((mpz_t*)big));
@@ -54,8 +56,9 @@ VAL MKBIGMc(VM* vm, void* big) {
54VAL GETBIG(VM * vm, VAL x) {
56VAL GETBIG(VM * vm, VAL x) {
55 if (ISINT(x)) {
57 if (ISINT(x)) {
56 mpz_t* bigint;
58 mpz_t* bigint;
57− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
59+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
58− bigint = allocate(vm, sizeof(mpz_t), 0);
60+ sizeof(mpz_t), 0);
61+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
59
62
60 mpz_init(*bigint);
63 mpz_init(*bigint);
61 mpz_set_si(*bigint, GETINT(x));
64 mpz_set_si(*bigint, GETINT(x));
@@ -71,8 +74,9 @@ VAL GETBIG(VM * vm, VAL x) {
71
74
72VAL bigAdd(VM* vm, VAL x, VAL y) {
75VAL bigAdd(VM* vm, VAL x, VAL y) {
73 mpz_t* bigint;
76 mpz_t* bigint;
74− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
77+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
75− bigint = allocate(vm, sizeof(mpz_t), 0);
78+ sizeof(mpz_t), 0);
79+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
76 mpz_add(*bigint, GETMPZ(x), GETMPZ(y));
80 mpz_add(*bigint, GETMPZ(x), GETMPZ(y));
77 SETTY(cl, BIGINT);
81 SETTY(cl, BIGINT);
78 cl -> info.ptr = (void*)bigint;
82 cl -> info.ptr = (void*)bigint;
@@ -81,8 +85,9 @@ VAL bigAdd(VM* vm, VAL x, VAL y) {
81
85
82VAL bigSub(VM* vm, VAL x, VAL y) {
86VAL bigSub(VM* vm, VAL x, VAL y) {
83 mpz_t* bigint;
87 mpz_t* bigint;
84− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
88+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
85− bigint = allocate(vm, sizeof(mpz_t), 0);
89+ sizeof(mpz_t), 0);
90+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
86 mpz_sub(*bigint, GETMPZ(x), GETMPZ(y));
91 mpz_sub(*bigint, GETMPZ(x), GETMPZ(y));
87 SETTY(cl, BIGINT);
92 SETTY(cl, BIGINT);
88 cl -> info.ptr = (void*)bigint;
93 cl -> info.ptr = (void*)bigint;
@@ -91,8 +96,9 @@ VAL bigSub(VM* vm, VAL x, VAL y) {
91
96
92VAL bigMul(VM* vm, VAL x, VAL y) {
97VAL bigMul(VM* vm, VAL x, VAL y) {
93 mpz_t* bigint;
98 mpz_t* bigint;
94− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
99+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
95− bigint = allocate(vm, sizeof(mpz_t), 0);
100+ sizeof(mpz_t), 0);
101+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
96 mpz_mul(*bigint, GETMPZ(x), GETMPZ(y));
102 mpz_mul(*bigint, GETMPZ(x), GETMPZ(y));
97 SETTY(cl, BIGINT);
103 SETTY(cl, BIGINT);
98 cl -> info.ptr = (void*)bigint;
104 cl -> info.ptr = (void*)bigint;
@@ -101,8 +107,9 @@ VAL bigMul(VM* vm, VAL x, VAL y) {
101
107
102VAL bigDiv(VM* vm, VAL x, VAL y) {
108VAL bigDiv(VM* vm, VAL x, VAL y) {
103 mpz_t* bigint;
109 mpz_t* bigint;
104− VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*), 0);
110+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +
105− bigint = allocate(vm, sizeof(mpz_t), 0);
111+ sizeof(mpz_t), 0);
112+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));
106 mpz_div(*bigint, GETMPZ(x), GETMPZ(y));
113 mpz_div(*bigint, GETMPZ(x), GETMPZ(y));
107 SETTY(cl, BIGINT);
114 SETTY(cl, BIGINT);
108 cl -> info.ptr = (void*)bigint;
115 cl -> info.ptr = (void*)bigint;
src/Core/CaseTree.hs+18−13
@@ -1,6 +1,7 @@
1−{-# LANGUAGE PatternGuards #-}
1+{-# LANGUAGE PatternGuards, DeriveFunctor #-}
2
2
3−module Core.CaseTree(CaseDef(..), SC(..), CaseAlt(..), Phase(..), CaseTree,
3+module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),
4+ Phase(..), CaseTree,
4 simpleCase, small, namesUsed, findCalls, findUsedArgs) where
5 simpleCase, small, namesUsed, findCalls, findUsedArgs) where
5
6
6import Core.TT
7import Core.TT
@@ -13,25 +14,29 @@ import Debug.Trace
13data CaseDef = CaseDef [Name] SC [Term]
14data CaseDef = CaseDef [Name] SC [Term]
14 deriving Show
15 deriving Show
15
16
16−data SC = Case Name [CaseAlt] -- invariant: lowest tags first
17+data SC' t = Case Name [CaseAlt' t] -- invariant: lowest tags first
17− | ProjCase Term [CaseAlt] -- special case for projections
18+ | ProjCase t [CaseAlt' t] -- special case for projections
18− | STerm Term
19+ | STerm t
19− | UnmatchedCase String -- error message
20+ | UnmatchedCase String -- error message
20− | ImpossibleCase -- already checked to be impossible
21+ | ImpossibleCase -- already checked to be impossible
21− deriving (Eq, Ord)
22+ deriving (Eq, Ord, Functor)
22{-!
23{-!
23deriving instance Binary SC
24deriving instance Binary SC
24!-}
25!-}
25
26
27+type SC = SC' Term
28+
26−data CaseAlt = ConCase Name Int [Name] SC
29+data CaseAlt' t = ConCase Name Int [Name] (SC' t)
27− | ConstCase Const SC
30+ | ConstCase Const (SC' t)
28− | DefaultCase SC
31+ | DefaultCase (SC' t)
29− deriving (Show, Eq, Ord)
32+ deriving (Show, Eq, Ord, Functor)
30{-!
33{-!
31deriving instance Binary CaseAlt
34deriving instance Binary CaseAlt
32!-}
35!-}
33
36
37+type CaseAlt = CaseAlt' Term
38+
34−instance Show SC where
39+instance Show t => Show (SC' t) where
35 show sc = show' 1 sc
40 show sc = show' 1 sc
36 where
41 where
37 show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++
42 show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++
src/IRTS/Compiler.hs+26−7
@@ -30,7 +30,8 @@ compile :: Target -> FilePath -> Term -> Idris ()
30compile target f tm
30compile target f tm
31 = do checkMVs
31 = do checkMVs
32 let tmnames = namesUsed (STerm tm)
32 let tmnames = namesUsed (STerm tm)
33− used <- mapM (allNames []) tmnames
33+ usedIn <- mapM (allNames []) tmnames
34+ let used = [UN "prim__subBigInt", UN "prim__addBigInt"] : usedIn
34 defsIn <- mkDecls tm (concat used)
35 defsIn <- mkDecls tm (concat used)
35 findUnusedArgs (concat used)
36 findUnusedArgs (concat used)
36 maindef <- irMain tm
37 maindef <- irMain tm
@@ -166,6 +167,9 @@ instance ToIR (TT Name) where
166 | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm
167 | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm
167 = do t' <- ir' env t
168 = do t' <- ir' env t
168 return t' -- TODO
169 return t' -- TODO
170+-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm
171+-- = do k' <- ir' env k
172+-- return (LOp LBPlus [k', LConst (BI 1)])
169 | (P (DCon t a) n _, args) <- unApply tm
173 | (P (DCon t a) n _, args) <- unApply tm
170 = irCon env t a n args
174 = irCon env t a n args
171 | (P _ n _, args) <- unApply tm
175 | (P _ n _, args) <- unApply tm
@@ -187,6 +191,8 @@ instance ToIR (TT Name) where
187 where mkUnused u i [] = []
191 where mkUnused u i [] = []
188 mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs
192 mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs
189 | otherwise = x : mkUnused u (i + 1) xs
193 | otherwise = x : mkUnused u (i + 1) xs
194+-- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _)
195+-- = return $ LConst (BI 0)
190 ir' env (P _ n _) = return $ LV (Glob n)
196 ir' env (P _ n _) = return $ LV (Glob n)
191 ir' env (V i) | i < length env = return $ LV (Glob (env!!i))
197 ir' env (V i) | i < length env = return $ LV (Glob (env!!i))
192 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm
198 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm
@@ -249,6 +255,9 @@ mkIty "FString" = FString
249mkIty "FPtr" = FPtr
255mkIty "FPtr" = FPtr
250mkIty "FUnit" = FUnit
256mkIty "FUnit" = FUnit
251
257
258+zname = NS (UN "O") ["Nat","Prelude"]
259+sname = NS (UN "S") ["Nat","Prelude"]
260+
252instance ToIR ([Name], SC) where
261instance ToIR ([Name], SC) where
253 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
262 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
254 tree' <- ir tree
263 tree' <- ir tree
@@ -259,26 +268,36 @@ instance ToIR SC where
259
268
260 ir' (STerm t) = ir t
269 ir' (STerm t) = ir t
261 ir' (UnmatchedCase str) = return $ LError str
270 ir' (UnmatchedCase str) = return $ LError str
262− ir' (ProjCase tm alts) = do alts' <- mapM mkIRAlt alts
271+ ir' (ProjCase tm alts) = do alts' <- mapM (mkIRAlt tm) alts
263 tm' <- ir tm
272 tm' <- ir tm
264 return $ LCase tm' alts'
273 return $ LCase tm' alts'
265− ir' (Case n alts) = do alts' <- mapM mkIRAlt alts
274+ ir' (Case n alts) = do alts' <- mapM (mkIRAlt (P Bound n Erased)) alts
266 return $ LCase (LV (Glob n)) alts'
275 return $ LCase (LV (Glob n)) alts'
267 ir' ImpossibleCase = return LNothing
276 ir' ImpossibleCase = return LNothing
268
277
278+ -- special cases for O and S
279+ -- Needs rethink: projections make this fail
280+-- mkIRAlt n (ConCase z _ [] rhs) | z == zname
281+-- = mkIRAlt n (ConstCase (BI 0) rhs)
282+-- mkIRAlt n (ConCase s _ [arg] rhs) | s == sname
283+-- = do n' <- ir n
284+-- rhs' <- ir rhs
285+-- return $ LDefaultCase
286+-- (LLet arg (LOp LBMinus [n', LConst (BI 1)])
287+-- rhs')
269− mkIRAlt (ConCase n t args rhs)
288+ mkIRAlt _ (ConCase n t args rhs)
270 = do rhs' <- ir rhs
289 = do rhs' <- ir rhs
271 return $ LConCase (-1) n args rhs'
290 return $ LConCase (-1) n args rhs'
272− mkIRAlt (ConstCase x rhs)
291+ mkIRAlt _ (ConstCase x rhs)
273 | matchable x
292 | matchable x
274 = do rhs' <- ir rhs
293 = do rhs' <- ir rhs
275 return $ LConstCase x rhs'
294 return $ LConstCase x rhs'
276 | matchableTy x
295 | matchableTy x
277 = do rhs' <- ir rhs
296 = do rhs' <- ir rhs
278 return $ LDefaultCase rhs'
297 return $ LDefaultCase rhs'
279− mkIRAlt (ConstCase c rhs)
298+ mkIRAlt _ (ConstCase c rhs)
280 = fail $ "Can't match on (" ++ show c ++ ")"
299 = fail $ "Can't match on (" ++ show c ++ ")"
281− mkIRAlt (DefaultCase rhs)
300+ mkIRAlt _ (DefaultCase rhs)
282 = do rhs' <- ir rhs
301 = do rhs' <- ir rhs
283 return $ LDefaultCase rhs'
302 return $ LDefaultCase rhs'
284
303