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

git.iko.soy/Idris-dev

Lazy and IO primitives in new rts

commit1f83787f285e9eedfb14dd0025fb74272ef97859 authorEdwin Brady <eb@cs.st-andrews.ac.uk> dateTue 22 May 2012, 11:41 (14 years ago) parent782d0f7

2 files changed+25−5

compare with master

unifiedsplit

src/RTS/Bytecode.hs+13−3 src/RTS/SC.hs+12−2

src/RTS/Bytecode.hs+13−3

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

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

3131 | SPLIT -- get arguments from constructor form

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

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

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

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

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

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

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

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

7980 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

8089 bc locs (SLet n v sc)

8190 = bc locs v ++

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

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

8594 bc locs (SFCall cname ty args)

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

8796 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

8998

9099 bc locs (SCon t args)

91100 = bc' locs (reverse args)

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

103112

104113 bc locs (SCase n alts)

105114 = 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]

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

108117 getCases ty _ cs (SDefaultCase e : rest)

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

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

119128 bc locs (SPrimOp p args)

120129 = bc' locs (reverse args)

121130 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)],

1818

1919data SCExp = SRef Name

2020 | SApp SCExp [SCExp]

21+ | SLazyApp Name [SCExp]

2122 | SLet Name SCExp SCExp

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

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

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

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

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

158159 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']

159171sPrim env f args = return Nothing

160172

161173doForeign env (_ : fgn : args)

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

163175 = let tys = getFTypes fgnArgTys

164176 rty = mkEty' ret in

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

166− -- wrap it in a prim__IO

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

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

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

170180