1f83787 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Lazy and IO primitives in new rts

1f83787Edwin Brady14 years ago

src/RTS/Bytecode.hs+13−3

compare with master

unifiedsplit

@@ -30,6 +30,7 @@ data BCOp = PUSH SValue

30 -- places constructor args on stack, last to first (first at ref 0)

31 | SPLIT -- get arguments from constructor form

32 | CALL Name Int -- name, number of arguments to take

33+ | CLOSURE Name Int -- as CALL, but always make the closure

33 | CALLVAR Int Int -- stack ref, number of arguments to take

34 | CALLVAR Int Int -- stack ref, number of arguments to take

34 | FOREIGNCALL String CType [CType] -- TT constants for types

35 | FOREIGNCALL String CType [CType] -- TT constants for types

35 | PRIMOP SPrim [Int] -- apply to list of stack references

36 | PRIMOP SPrim [Int] -- apply to list of stack references

@@ -77,6 +78,14 @@ instance BC SCExp where

77 = [CALLVAR (length args) (length args)]

78 = [CALLVAR (length args) (length args)]

78 bc' locs (x : xs) = bc locs x ++

79 bc' locs (x : xs) = bc locs x ++

79 bc' (offset locs) xs

80 bc' (offset locs) xs

81+ bc locs (SLazyApp f args)

82+ = bc' locs (reverse args) f

83+ where bc' locs [] n

84+ = case lookup n locs of

85+ Just i -> error "Internal error: Lazy call"

86+ Nothing -> [CLOSURE n (length args)]

87+ bc' locs (x : xs) f = bc locs x ++

88+ bc' (offset locs) xs f

80 bc locs (SLet n v sc)

89 bc locs (SLet n v sc)

81 = bc locs v ++

90 = bc locs v ++

82 bc ((n, 0) : offset locs) sc ++

91 bc ((n, 0) : offset locs) sc ++

@@ -85,7 +94,7 @@ instance BC SCExp where

85 bc locs (SFCall cname ty args)

94 bc locs (SFCall cname ty args)

86 = bc' locs (reverse (map fst args))

95 = bc' locs (reverse (map fst args))

87 where bc' locs [] = [FOREIGNCALL cname ty (map snd args)]

96 where bc' locs [] = [FOREIGNCALL cname ty (map snd args)]

88− bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs

97+ bc' locs (x : xs) = bc locs x ++ EVAL True : bc' (offset locs) xs

90 bc locs (SCon t args)

99 bc locs (SCon t args)

91 = bc' locs (reverse args)

100 = bc' locs (reverse args)

@@ -103,7 +112,7 @@ instance BC SCExp where

103

112

104 bc locs (SCase n alts)

113 bc locs (SCase n alts)

105 = let (def, cases, ty) = getCases CASE Nothing [] alts in

114 = let (def, cases, ty) = getCases CASE Nothing [] alts in

106− bc locs (SRef n) ++ [ty cases def]

115+ bc locs (SRef n) ++ [EVAL True, ty cases def]

107 where getCases ty def cs [] = (def, reverse cs, ty)

116 where getCases ty def cs [] = (def, reverse cs, ty)

108 getCases ty _ cs (SDefaultCase e : rest)

117 getCases ty _ cs (SDefaultCase e : rest)

109 = getCases ty (Just (bc locs e)) cs rest

118 = getCases ty (Just (bc locs e)) cs rest

@@ -119,4 +128,5 @@ instance BC SCExp where

119 bc locs (SPrimOp p args)

128 bc locs (SPrimOp p args)

120 = bc' locs (reverse args)

129 = bc' locs (reverse args)

121 where bc' locs [] = [PRIMOP p [0..length args-1]]

130 where bc' locs [] = [PRIMOP p [0..length args-1]]

122− bc' locs (x : xs) = bc locs x ++ bc' (offset locs) xs

131+ bc' locs (x : xs) = bc locs x ++ EVAL True : bc' (offset locs) xs

132+

src/RTS/SC.hs+12−2

@@ -18,6 +18,7 @@ data SCDef = SCDef { sc_args :: [(Name, CType)],

19data SCExp = SRef Name

20 | SApp SCExp [SCExp]

21+ | SLazyApp Name [SCExp]

21 | SLet Name SCExp SCExp

22 | SLet Name SCExp SCExp

22 | SFCall String CType [(SCExp, CType)] -- foreign call with types

23 | SFCall String CType [(SCExp, CType)] -- foreign call with types

23 | SCon Tag [SCExp] -- constructor, assume saturated (forcing does this)

24 | SCon Tag [SCExp] -- constructor, assume saturated (forcing does this)

@@ -156,6 +157,17 @@ instance Lift CaseAlt SAlt where

156sPrim :: [Name] -> TT Name -> [TT Name] -> State SCState (Maybe SCExp)

157sPrim :: [Name] -> TT Name -> [TT Name] -> State SCState (Maybe SCExp)

157sPrim env (P _ (UN "mkForeign") _) args = do x <- doForeign env args

158sPrim env (P _ (UN "mkForeign") _) args = do x <- doForeign env args

158 return (Just x)

159 return (Just x)

160+sPrim env (P _ (UN "lazy") _) [_, arg]

161+ = do arg' <- sc env arg

162+ fn <- nextSC

163+ add (fn, SCDef (zip env (repeat Nothing)) arg')

164+ return $ Just $ SLazyApp fn (map SRef env)

165+sPrim env (P _ (UN "prim__IO") _) [v] = do v' <- sc env v

166+ return $ Just v'

167+sPrim env (P _ (UN "io_bind") _) [_,_,v,k]

168+ = do v' <- sc env v

169+ k' <- sc env k

170+ return $ Just $ SApp k'[v']

159sPrim env f args = return Nothing

171sPrim env f args = return Nothing

160

172

161doForeign env (_ : fgn : args)

173doForeign env (_ : fgn : args)

@@ -163,8 +175,6 @@ doForeign env (_ : fgn : args)

163 = let tys = getFTypes fgnArgTys

175 = let tys = getFTypes fgnArgTys

164 rty = mkEty' ret in

176 rty = mkEty' ret in

165 do args' <- mapM (sc env) args

177 do args' <- mapM (sc env) args

166− -- wrap it in a prim__IO

167− -- return $ con_ 0 @@ impossible @@

168 return $ SFCall fgnName rty (zip args' tys)

178 return $ SFCall fgnName rty (zip args' tys)

169 | otherwise = fail "Badly formed foreign function call"

179 | otherwise = fail "Badly formed foreign function call"

170

180