914a765 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Merge branch 'master' of github.com:edwinb/Idris-dev

commit914a765848eec4b8d5c1f2274b5eb860482bf1d0 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateSun 22 Sep 2013, 09:04 (13 years ago) parent73bdc53 f86ba91

6 files changed+74−27

compare with master

unifiedsplit

lib/Prelude.idr+1−1 lib/System.idr+39−2 llvm/defs.c+5−2 rts/idris_stdfgn.c+6−4 rts/idris_stdfgn.h+2−1 src/IRTS/Bytecode.hs+21−17

lib/Prelude.idr+1−1

@@ -480,7 +480,7 @@ nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

480480

481481partial

482482nullStr : String -> IO Bool

483−nullStr p = do ok <- mkForeign (FFun "isNullString" [FString] FInt) p

483+nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

484484 return (ok /= 0);

485485

486486partial

lib/System.idr+39−2

@@ -20,17 +20,54 @@ getArgs = do n <- numArgs

2020 do arg <- getArg i

2121 ga' (arg :: acc) (i+1) n

2222

23+-- Retrieves an value from the environment, if the given key is present,

24+-- otherwise it returns Nothing.

2325getEnv : String -> IO (Maybe String)

2426getEnv key = do

2527 str_ptr <- getEnv'

26− exists <- nullStr str_ptr

27− if exists

28+ is_nil <- nullStr str_ptr

29+ if is_nil

2830 then pure Nothing

2931 else pure (Just str_ptr)

3032 where

3133 getEnv' : IO String

3234 getEnv' = mkForeign (FFun "getenv" [FString] FString) key

3335

36+-- Sets an environment variable with a given value.

37+-- Returns true if the operation was successful.

38+setEnv : String -> String -> IO Bool

39+setEnv key value = do

40+ ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1

41+ return (ok == 0)

42+

43+-- Unsets an environment variable.

44+-- Returns true if the variable was able to be unset.

45+unsetEnv : String -> IO Bool

46+unsetEnv key = do

47+ ok <- mkForeign (FFun "unsetenv" [FString] FInt) key

48+ return (ok == 0)

49+

50+getEnvironment : IO (List (String, String))

51+getEnvironment = getAllPairs 0 []

52+ where

53+ getEnvPair : Int -> IO String

54+ getEnvPair i = mkForeign (FFun "getEnvPair" [FInt] FString) i

55+

56+ splitEq : String -> (String, String)

57+ splitEq str =

58+ -- FIXME: There has to be a better way to split this up

59+ let (k, v) = break (== '=') str in

60+ let (_, v') = break (/= '=') v in

61+ (k, v')

62+

63+ getAllPairs : Int -> List String -> IO (List (String, String))

64+ getAllPairs n acc = do

65+ envPair <- getEnvPair n

66+ is_nil <- nullStr envPair

67+ if is_nil

68+ then return $ reverse $ map splitEq acc

69+ else getAllPairs (n + 1) (envPair :: acc)

70+

3471exit : Int -> IO ()

3572exit code = mkForeign (FFun "exit" [FInt] FUnit) code

3673

llvm/defs.c+5−2

@@ -1,9 +1,12 @@

1+#include <stdlib.h>

12#include <stdio.h>

23#include <gmp.h>

34#include <gc.h>

45#include <string.h>

56#include <inttypes.h>

8+extern char** environ;

710void putStr(const char *str) {

811 fputs(str, stdout);

912}

@@ -119,8 +122,8 @@ int isNull(void* ptr) {

119122 return ptr==NULL;

120123}

121124

122−int isNullString(char* str) {

123− return str==NULL;

125+char* getEnvPair(int i) {

126+ return *(environ + i);

124127}

125128

126129void idris_memset(void* ptr, size_t offset, uint8_t c, size_t size) {

rts/idris_stdfgn.c+6−4

@@ -1,6 +1,8 @@

11#include "idris_stdfgn.h"

22#include "idris_rts.h"

4+extern char** environ;

46void putStr(char* str) {

57 printf("%s", str);

68}

@@ -34,10 +36,10 @@ int isNull(void* ptr) {

3436 return ptr==NULL;

3537}

3638

37−int isNullString(char* str) {

38− return str==NULL;

39−}

40−

4139void* idris_stdin() {

4240 return (void*)stdin;

4341}

42+

43+char* getEnvPair(int i) {

44+ return *(environ + i);

45+}

rts/idris_stdfgn.h+2−1

@@ -13,7 +13,8 @@ int fileError(void* h);

1313void fputStr(void*h, char* str);

1414

1515int isNull(void* ptr);

16−int isNullString(char* str);

1716void* idris_stdin();

1817

18+char* getEnvPair(int i);

19+

1920#endif

src/IRTS/Bytecode.hs+21−17

@@ -8,7 +8,7 @@ import IRTS.Simplified

88import Core.TT

99import Data.Maybe

1010

11−{- We have:

11+{- We have:

1212

1313BASE: Current stack frame's base

1414TOP: Top of stack

@@ -32,14 +32,14 @@ data BC = ASSIGN Reg Reg

3232 | CASE Bool -- definitely a constructor, no need to check, if true

3333 Reg [(Int, [BC])] (Maybe [BC])

3434 | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards

35− | PROJECTINTO Reg Reg Int -- project argument from one reg into another

35+ | PROJECTINTO Reg Reg Int -- project argument from one reg into another

3636 | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])

3737 | CALL Name

3838 | TAILCALL Name

39− | FOREIGNCALL Reg FLang FType String [(FType, Reg)]

40− | SLIDE Int -- move this number from TOP to BASE

39+ | FOREIGNCALL Reg FLang FType String [(FType, Reg)]

40+ | SLIDE Int -- move this number from TOP to BASE

4141 | REBASE -- set BASE = OLDBASE

42− | RESERVE Int -- reserve n more stack items

42+ | RESERVE Int -- reserve n more stack items

4343 -- (i.e. check there's space, grow if necessary)

4444 | ADDTOP Int -- move the top of stack up

4545 | TOPBASE Int -- set TOP = BASE + n

@@ -51,7 +51,7 @@ data BC = ASSIGN Reg Reg

5151 deriving Show

5252

5353toBC :: (Name, SDecl) -> (Name, [BC])

54−toBC (n, SFun n' args locs exp)

54+toBC (n, SFun n' args locs exp)

5555 = (n, reserve locs ++ bc RVal exp True)

5656 where reserve 0 = []

5757 reserve n = [RESERVE n, ADDTOP n]

@@ -63,10 +63,14 @@ bc :: Reg -> SExp -> Bool -> -- returning

6363 [BC]

6464bc reg (SV (Glob n)) r = bc reg (SApp False n []) r

6565bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r

66−bc reg (SApp False f vs) r

67− = RESERVE (length vs) : moveReg 0 vs

68− ++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++

69− assign reg RVal ++ clean r

66+bc reg (SApp False f vs) r =

67+ if argCount == 0

68+ then moveReg 0 vs ++ [STOREOLD, BASETOP 0, CALL f] ++ ret

69+ else RESERVE argCount : moveReg 0 vs ++

70+ [STOREOLD, BASETOP 0, ADDTOP argCount, CALL f] ++ ret

71+ where

72+ ret = assign reg RVal ++ clean r

73+ argCount = length vs

7074bc reg (SApp True f vs) r

7175 = RESERVE (length vs) : moveReg 0 vs

7276 ++ [SLIDE (length vs), TOPBASE (length vs), TAILCALL f]

@@ -78,16 +82,16 @@ bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]

7882 ++ clean r

7983bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r

8084 where getL (Loc x) = L x

81−bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r

85+bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r

8286bc reg (SConst i) r = ASSIGNCONST reg i : clean r

8387bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r

8488 where getL (Loc x) = L x

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

8690bc reg SNothing r = NULL reg : clean r

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

91+bc reg (SCase (Loc l) alts) r

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

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

90−bc reg (SChkCase (Loc l) alts) r

94+bc reg (SChkCase (Loc l) alts) r

9195 = conCase False reg (L l) alts r

9296

9397isConst [] = False

@@ -107,12 +111,12 @@ conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)

107111constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs)

108112 (defaultAlt reg xs r)]

109113

110−caseAlt l reg r (SConCase lvar tag _ args e)

111− = Just (tag, PROJECT l lvar (length args) : bc reg e r)

114+caseAlt l reg r (SConCase lvar tag _ args e)

115+ = Just (tag, PROJECT l lvar (length args) : bc reg e r)

112116caseAlt l reg r _ = Nothing

113117

114−constAlt l reg r (SConstCase c e)

115− = Just (c, bc reg e r)

118+constAlt l reg r (SConstCase c e)

119+ = Just (c, bc reg e r)

116120constAlt l reg r _ = Nothing

117121

118122defaultAlt reg [] r = Nothing