From ef9684b0bf2780800ae3349819239e4f0a0c9c25 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Wed, 13 Dec 2017 23:25:53 +0100 Subject: Make fiboY work --- compiler.hs | 19 +++++++++------ fiboY.lisp | 39 ++++++++++--------------------- vm.hs | 78 ++++++++++++++++++++++++++++++++++++++++--------------------- 3 files changed, 75 insertions(+), 61 deletions(-) diff --git a/compiler.hs b/compiler.hs index 64b887c..2e3b80b 100644 --- a/compiler.hs +++ b/compiler.hs @@ -6,6 +6,7 @@ import Control.Monad.State.Strict import Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Debug.Trace import AST import Intermediate @@ -70,8 +71,11 @@ data ScopeItem = SIParam Int | SIClosure Int | SIGlobal newtype CM a = CM {unCM :: StateT CompState (Except String) a} deriving (Functor, Applicative, Monad, MonadState CompState, MonadError String) +-- TODO: extra info like number of arguments, dunno, might be useful builtinMap :: Map.Map Name () -builtinMap = Map.fromList [("+", ()), ("-", ()), ("<=", ()), ("print", ())] +builtinMap = Map.fromList [ + ("+", ()), ("-", ()), ("<=", ()), ("print", ()), + ("list", ()), ("car", ()), ("cdr", ())] bbId :: BB -> Int bbId (BB i _ _) = i @@ -228,6 +232,7 @@ genTValue (TVDefine name value) nextnext = do dref <- genTemp defineAdd name dref vref <- genTValue value nextnext + -- traceM $ "Defining '" ++ name ++ "', ref " ++ show dref ++ ", with value " ++ show vref addIns (dref, IAssign vref) return RNone genTValue (TVLambda args body closure) nextnext = do @@ -245,12 +250,11 @@ genTValue (TVLambda args body closure) nextnext = do resref <- case closure of [] -> return (RSClo uname) _ -> do - refs <- foldM (\refs' cname -> do - b <- newBlock - r <- genTValue (TVName cname undefined) b - switchBlock b - return (r : refs')) - [] closure + refs <- forM closure $ \cname -> do + b <- newBlock + r <- genTValue (TVName cname undefined) b + switchBlock b + return r r <- genTemp addIns (r, IAllocClo uname refs) return r @@ -279,3 +283,4 @@ genTValue (TVName name _) nextnext = do _ -> throwError $ "Use of undefined name \"" ++ name ++ "\"" setTerm $ IJmp nextnext return r +genTValue TVEllipsis _ = throwError "Ellipses not supported in compiler" diff --git a/fiboY.lisp b/fiboY.lisp index f46c00a..d12a5ab 100644 --- a/fiboY.lisp +++ b/fiboY.lisp @@ -1,39 +1,24 @@ +(define cadr (l) (car (cdr l))) +(define caddr (l) (car (cdr (cdr l)))) + (define YY (recur) (lambda (f) (lambda (a) (f ((recur recur) f) a)))) (define Y (YY YY)) -(define forX (recur (low high func)) - (if (low <= high) +(define forX (recur low_high_func) + (if (<= (car low_high_func) (cadr low_high_func)) (do - (func low) - (recur (list (+ low 1) high func))) + ((caddr low_high_func) (car low_high_func)) + (recur (list (+ (car low_high_func) 1) (cadr low_high_func) (caddr low_high_func)))) '())) (define for (Y forX)) -(define fibohelperX (recur (n a b)) - (if (n <= 0) a - (recur (list (- n 1) b (+ a b))))) +(define fibohelperX (recur n_a_b) + (if (<= (car n_a_b) 0) (cadr n_a_b) + (recur (list (- (car n_a_b) 1) (caddr n_a_b) (+ (cadr n_a_b) (caddr n_a_b)))))) (define fibohelper (Y fibohelperX)) -(define fibo (n) (fibohelper (n 0 1))) - - - - - -; Fill in the dots with the lines below... -; If you're done, try to dump the whole expression into test.hs. - -; ((lambda (YY) ...) (lambda (recur) (lambda (f) (lambda (a) (f ((recur recur) f) a))))) -; -; ((lambda (Y) ...) (YY YY)) -; -; ((lambda (forX) ...) (lambda (recur args) ; args: (low high func) -; (if ((car args) <= (cadr args)) -; (do -; ((cadr (cdr args)) (car args)) -; (recur (list (+ low 1) high func))) -; '()))) - +(define fibo (n) (fibohelper (list n 0 1))) +(for (list 1 25 (lambda (n) (print (fibo n))))) diff --git a/vm.hs b/vm.hs index c21e228..04de0c5 100644 --- a/vm.hs +++ b/vm.hs @@ -21,7 +21,13 @@ type TempMap = Map.Map Int RunValue data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -}) -data RunValue = RClosure Name [RunValue] | RValue Value +-- TODO: are more constructors from Value needed? +data RunValue + = RVClosure Name [RunValue] + | RVList [RunValue] + | RVNum Int + | RVString String + | RVQuoted RunValue deriving Show kErrorExit :: String @@ -47,20 +53,28 @@ vmRunInstr :: Info -> State -> Instruction -> IO State -- vmRunInstr _ _ ins | traceShow ins False = undefined vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest, instr) = case instr of IAssign ref -> return (assignRef state dest (findRef tmap ref)) - IParam i -> return (assignRef state dest (args !! i)) - IClosure i -> return (assignRef state dest (closure !! i)) - IData i -> return (assignRef state dest (RValue (datas !! i))) - ICallC cl as -> case findRef tmap cl of - RClosure clname clvals -> case Map.lookup clname gfds of - Just (GlobFuncDef b _ _) -> - let Just bb = Map.lookup b bbmap - in do - -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as)) - (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb - return (assignRef state dest rv) - Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as)) - _ -> error "VM: Cannot call non-closure object" - IAllocClo name clrefs -> return (assignRef state dest (RClosure name (map (findRef tmap) clrefs))) + IParam i -> + if i < length args then return (assignRef state dest (args !! i)) + else error $ show closure ++ ", " ++ show i ++ ", param-out-of-range" + IClosure i -> + if i < length closure then return (assignRef state dest (closure !! i)) + else error $ show closure ++ ", " ++ show i ++ ", closure-out-of-range" + IData i -> + if i < length datas then return (assignRef state dest (toRunValue (datas !! i))) + else error "data-out-of-range" + ICallC cl as -> + -- trace ("callc " ++ show (findRef tmap cl) ++ " " ++ show (map (findRef tmap) as)) $ + case findRef tmap cl of + RVClosure clname clvals -> case Map.lookup clname gfds of + Just (GlobFuncDef b _ _) -> + let Just bb = Map.lookup b bbmap + in do + -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as)) + (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb + return (assignRef state dest rv) + Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as)) + obj -> error $ "VM: Cannot call non-closure object: " ++ show obj + IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs))) IDiscard _ -> return state vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State) @@ -72,9 +86,9 @@ vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of IUnknown -> undefined findRef :: TempMap -> Ref -> RunValue -findRef _ (RConst n) = RValue (VNum n) +findRef _ (RConst n) = RVNum n findRef tmap (RTemp i) = fromJust (Map.lookup i tmap) -findRef _ (RSClo name) = RClosure name [] +findRef _ (RSClo name) = RVClosure name [] findRef _ RNone = error "VM: None ref used" assignRef :: State -> Ref -> RunValue -> State @@ -83,19 +97,29 @@ assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned" vmRunBuiltin :: Name -> [RunValue] -> IO RunValue -- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined -vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RValue (VList [])) -vmRunBuiltin "<=" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (fromEnum (a <= b)))) -vmRunBuiltin "+" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a + b))) -vmRunBuiltin "-" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a - b))) -vmRunBuiltin "car" [RValue (VList (a:_))] = return (RValue a) -vmRunBuiltin "cdr" [RValue (VList (_:a))] = return (RValue (VList a)) +vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList []) +vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b))) +vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b)) +vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b)) +vmRunBuiltin "car" [RVList (a:_)] = return a +vmRunBuiltin "cdr" [RVList (_:a)] = return (RVList a) +vmRunBuiltin "list" values = return (RVList values) vmRunBuiltin name args = error (name ++ " " ++ show args) printshow :: RunValue -> String -printshow (RValue (VString str)) = str -printshow (RValue value) = show value -printshow (RClosure _ _) = "[closure]" +printshow (RVString str) = str +printshow (RVList values) = show values +printshow (RVNum i) = show i +printshow (RVQuoted value) = '\'' : show value +printshow (RVClosure _ _) = "[closure]" truthy :: RunValue -> Bool -truthy (RValue (VNum n)) = n /= 0 +truthy (RVNum n) = n /= 0 truthy _ = True + +toRunValue :: Value -> RunValue +toRunValue (VList values) = RVList (map toRunValue values) +toRunValue (VNum i) = RVNum i +toRunValue (VString s) = RVString s +toRunValue (VQuoted value) = RVQuoted (toRunValue value) +toRunValue _ = undefined -- cgit v1.2.3