X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=gen.icl;h=e92954ccd16dff6be01145b895e6652f34bfd3a5;hb=714af3007a284a4a9f5f820dc6f26a45034da47e;hp=6020d03956f7f49a244572a77761495f18d73cd0;hpb=555e682444519f46b33ad9b3455df891c53d47c6;p=cc1516.git diff --git a/gen.icl b/gen.icl index 6020d03..e92954c 100644 --- a/gen.icl +++ b/gen.icl @@ -33,33 +33,54 @@ FALSE :== 0 :: SSMProgram :== [Instr] :: GenError = Error String :: Addressbook :== 'Map'.Map String Address -:: Address = LAB String Int | ADDR Int +:: Address = LAB String Int Int | ADDR Int Int :: Gen a :== RWST () SSMProgram (Addressbook, [Label]) (Either GenError) a labelStream :: [Label] labelStream = ["lbl_" +++ toString i\\i<-[1..]] -defaultAddressBook :: Addressbook -defaultAddressBook = extend "1printint" (LAB "1printint" 1) - $ extend "1printchar" (LAB "1printchar" 1) - $ extend "read" (LAB "read" 0) - $ extend "1readint" (LAB "1readint" 0) - $ extend "isEmpty" (LAB "isempty" 1) - 'Map'.newMap +defaultAddressBook :: [FunDecl] -> Addressbook +defaultAddressBook fd = extend "1printint" (LAB "1printint" 1 0) + $ extend "1printchar" (LAB "1printchar" 1 1) + $ extend "read" (LAB "read" 0 2) + $ extend "1readint" (LAB "1readint" 0 3) + $ extend "isEmpty" (LAB "isempty" 1 4) + $ addFuncs fd 5 + where + addFuncs [] _ = 'Map'.newMap + addFuncs [(FunDecl _ k args _ _ _):xs] n = + extend k (LAB k (length args) n) $ addFuncs xs (n+1) gen :: AST -> Either String String -gen (AST fds) = case evalRWST prog () (defaultAddressBook, labelStream) of +gen (AST fds) = case evalRWST prog () (defaultAddressBook fds, labelStream) of Left (Error e) = Left e Right (_, p) = Right $ toString p where prog = tell [ Instr "bsr" [L "main"] "", Instr "halt" [] "" - ] >>| tell programContext + ] >>| tell (programContext fds) >>| mapM_ g fds -programContext :: SSMProgram -programContext = [Lab "1printint" +programContext :: [FunDecl] -> SSMProgram +programContext x = [Lab "1func" + :fS ["1printint" ,"1printchar" + ,"read" ,"1readint" + ,"isEmpty":map (\(FunDecl _ k _ _ _ _)->k) x] 0] ++ context + where + + fS :: [String] Int -> SSMProgram + fS [] _ = [] + fS [k:xs] n = [ + Lab $ "1next" +++ toString n + ,Instr "ldr" [Raw "R5"] "" + ,Instr "ldc" [Lit n] $ "branch to: " +++ k + ,Instr "eq" [] "" + ,Instr "brf" [L $ "1next" +++ (toString $ n + 1)] "" + ,Instr "bra" [L k] "" + :fS xs $ n+1] + context :: SSMProgram + context = [Lab "1printint" ,Instr "link" [Lit 0] "" ,Instr "ldl" [Lit -2] "load first argument" ,Instr "trap" [Lit 0] "print int" @@ -71,12 +92,6 @@ programContext = [Lab "1printint" ,Instr "trap" [Lit 1] "print char" ,Instr "unlink" [] "" ,Instr "ret" [] "" - ,Lab "1readint" - ,Instr "link" [Lit 0] "" - ,Instr "trap" [Lit 10] "read int" - ,Instr "str" [Raw "RR"] "" - ,Instr "unlink" [] "" - ,Instr "ret" [] "" ,Lab "read" ,Instr "link" [Lit 0] "" ,Instr "trap" [Lit 11] "read char" @@ -95,7 +110,6 @@ programContext = [Lab "1printint" ,Lab "read" ] -//helper functions for the gen monad getAdressbook :: Gen Addressbook getAdressbook = gets fst @@ -136,8 +150,8 @@ instance g Op2 where BiCons = abort "Shit, Cons, how to deal with this?" instance g FieldSelector where - g FieldFst = tell [Instr "lda" [Lit 0] "fst"] - g FieldSnd = tell [Instr "lda" [Lit 1] "snd"] + g FieldFst = tell [Instr "lda" [Lit -1] "fst"] + g FieldSnd = tell [Instr "lda" [Lit 0] "snd"] g FieldHd = tell [Instr "lda" [Lit -1] "hd"] g FieldTl = tell [Instr "lda" [Lit 0] "tl"] @@ -154,27 +168,135 @@ instance g Expr where >>| tell [Instr "sth" [] ""] g (Op2Expr _ e1 op e2) = g e1 >>| g e2 >>| g op g (TupleExpr _ (e1,e2)) = g e1 - >>| tell [Instr "sth" [] ""] >>| g e2 - >>| tell [Instr "sth" [] ""] - >>| tell [Instr "ajs" [Lit -1] ""] + >>| tell [Instr "stmh" [Lit 2] ""] g (VarExpr _ (VarDef k fs)) = getAdressbook >>= \ab->case 'Map'.get k ab of - Just (ADDR t) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure () - _ = liftT (Left $ Error "Higher order functions not implemented") + Just (ADDR t arity) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure () + Just (LAB l _ fn) = tell + [Instr "ldc" [Lit fn] "" + ,Instr "ldc" [Lit 0] "" + ,Instr "stmh" [Lit 2] ""] g (FunExpr _ k es fs) = getAdressbook >>= \ab->case 'Map'.get k ab of - Just (LAB l arity) = if (arity <> (length es)) - (liftT $ Left $ Error "Higher order functions not implemented") + //Identifier points to function + Just (LAB l arity fn) = if (arity <> (length es)) + //Function is not complete + ( tell + [Instr "ldc" [Lit fn] "Store function number" + ,Instr "sth" [] "" + ,Instr "ldc" [Lit $ length es] "Store arity" + ,Instr "sth" [] "" + ,Instr "ajs" [Lit -1] ""] + >>| mapM_ g es + >>| if (isEmpty es) (pure ()) (tell + [Instr "stmh" [Lit $ length es] "Store arguments" + ,Instr "ajs" [Lit -1] ""])) + //Function is complete ( mapM_ g es >>| jump "bsr" k - >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args - >>| tell [Instr "ldr" [Raw "RR"] ""]) - _ = liftT (Left $ Error "Funcall to variable?") + >>| tell + [Instr "ajs" [Lit $ ~(length es)] "Clean arguments" + ,Instr "ldr" [Raw "RR"] ""]) + //Identifier points to variable, thus higher order function + Just (ADDR t arity) = if (arity <> (length es)) + //Function is still not complete + ( fresh >>= \finish->fresh >>= \start->tell [ + //Store function number + Instr "ldl" [Lit t] "STARTING HIGHER ORDER UPDATE" + ,Instr "ldh" [Lit 0] "get function number" + ,Instr "sth" [] "Store" + //Store function arity + ,Instr "ldl" [Lit t] "get pointer again" + ,Instr "ldh" [Lit 1] "get function arity" + ,Instr "ldc" [Lit $ length es] "add argument number" + ,Instr "add" [] "add" + ,Instr "sth" [] "Store" + ,Instr "ajs" [Lit -1] "Adjust pointer" + //load the arguments + ,Instr "ldl" [Lit t] "" + ,Instr "ldh" [Lit 1] "Load available arguments" + ,Instr "str" [Raw "R5"] "Store available args in register" + ,Instr "ldc" [Lit 0] "Store offset" + ,Instr "str" [Raw "R6"] "Store offset in register" + ,Lab start + ,Instr "ldr" [Raw "R5"] "" + ,Instr "ldc" [Lit 0] "" + ,Instr "eq" [] "" + ,Instr "brt" [L finish] "Done pushing arg, bye" + //Load heapadress + ,Instr "ldl" [Lit t] "" + ,Instr "ldr" [Raw "R6"] "" + ,Instr "add" [] "Corrected heapaddress" + ,Instr "ldh" [Lit 2] "Load argument" + ,Instr "sth" [] "And store it immediatly after" + //Decrease available arguments + ,Instr "ldr" [Raw "R5"] "" + ,Instr "ldc" [Lit 1] "" + ,Instr "sub" [] "" + ,Instr "str" [Raw "R5"] "" + //Increase available arguments + ,Instr "ldr" [Raw "R6"] "" + ,Instr "ldc" [Lit 1] "" + ,Instr "add" [] "" + ,Instr "str" [Raw "R6"] "" + ,Instr "bra" [L start] "" + ,Lab finish + ] + >>| mapM_ g es + >>| tell + [Instr "stmh" [Lit $ length es] "Store extra args" + ,Instr "ajs" [Lit -1] ""] + ) + //Function is complete + ( fresh >>= \finish->fresh >>= \start->tell [ + Instr "ldl" [Lit t] "STARTING HIGHER ORDER CALL" + ,Instr "ldh" [Lit 1] "Load available arguments" + ,Instr "str" [Raw "R5"] "Store available args in register" + ,Instr "ldc" [Lit 0] "Store offset" + ,Instr "str" [Raw "R6"] "Store offset in register" + + ,Lab start + ,Instr "ldr" [Raw "R5"] "" + ,Instr "ldc" [Lit 0] "" + ,Instr "eq" [] "" + ,Instr "brt" [L finish] "Done pushing arg, bye" + //Load heapadress + ,Instr "ldl" [Lit t] "" + ,Instr "ldr" [Raw "R6"] "" + ,Instr "add" [] "Corrected heapaddress" + ,Instr "ldh" [Lit 2] "Load argument" + //Decrease available arguments + ,Instr "ldr" [Raw "R5"] "" + ,Instr "ldc" [Lit 1] "" + ,Instr "sub" [] "" + ,Instr "str" [Raw "R5"] "" + //Increase available arguments + ,Instr "ldr" [Raw "R6"] "" + ,Instr "ldc" [Lit 1] "" + ,Instr "add" [] "" + ,Instr "str" [Raw "R6"] "" + ,Instr "bra" [L start] "" + ,Lab finish + ] + >>| mapM_ g es + >>| tell + [Instr "ldl" [Lit t] "" + ,Instr "ldh" [Lit 0] "Get function number" + ,Instr "str" [Raw "R5"] "" + ,Instr "bsr" [L "1func"] "" + ,Instr "ldr" [Raw "MP"] "" + ,Instr "ldc" [Lit t] "" + ,Instr "add" [] "" + ,Instr "str" [Raw "SP"] "" + ,Instr "ldr" [Raw "RR"] "" + ] + ) + Nothing = liftT (Left $ Error "Undefined function!!!") jump :: String String -> Gen () jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"]) - Just (LAB t _) = tell [Instr instr [L t] (k +++"()")] - Just (ADDR t) = liftT (Left $ Error $ "PANIC: jump should go to label") + Just (LAB t _ _) = tell [Instr instr [L t] (k +++"()")] + Just (ADDR t arity) = abort "NO ADDRESS JUMPING FFS" instance g Stmt where g (IfStmt cond th el) = @@ -199,11 +321,11 @@ instance g Stmt where g (AssStmt (VarDef k fs) e) = g e >>| getAdressbook >>= \ab->case 'Map'.get k ab of Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as var"]) - Just (LAB t _) = liftT (Left $ Error $ "PANIC: cannot assign to function") - Just (ADDR t) = tell [Instr "stl" [Lit t] ""] + Just (LAB t _ _) = liftT (Left $ Error $ "PANIC: cannot assign to function") + Just (ADDR t ar) = tell [Instr "stl" [Lit t] ""] g (FunStmt k es fs) = mapM_ g es >>| jump "bsr" k - >>| mapM_ (const $ tell [Instr "ajs" [Lit -1] ""]) es //clean up args + >>| tell [Instr "ajs" [Lit (~(length es))] ""] //clean up args >>| mapM_ g fs >>| pure () g (ReturnStmt Nothing) = tell [Instr "unlink" [] ""] @@ -213,20 +335,27 @@ instance g Stmt where >>| g (ReturnStmt Nothing) foldVarDecl :: Int VarDecl -> Gen Int -foldVarDecl x (VarDecl _ _ k e) = g e +foldVarDecl x (VarDecl _ mt k e) = g e >>| annote x k - >>| updateAdressbook (extend k (ADDR x)) >>| pure (x + 1) + >>| updateAdressbook (extend k (ADDR x $ arity $ fromJust mt)) + >>| pure (x + 1) + +arity :: Type -> Int +arity (_ ->> x) = 1 + arity x +arity _ = 0 -addVars :: [String] -> (Addressbook -> Addressbook) -addVars [] = id -addVars [x:xs] = \ab->extend x (ADDR (-2 - (length xs))) (addVars xs ab) +addVars :: Type [String] -> (Addressbook -> Addressbook) +addVars _ [] = id +addVars (t ->> ts) [x:xs] = \ab-> + extend x (ADDR (-2 - (length xs)) (arity t)) (addVars ts xs ab) +addVars t [x] = \ab-> + extend x (ADDR -2 0) ab instance g FunDecl where - g (FunDecl _ k args _ vds stms) = + g (FunDecl _ k args mt vds stms) = //varDecls can call the enclosing function, so first reserve a label for it - updateAdressbook (extend k (LAB k (length args))) >>| getAdressbook >>= \oldMap -> - updateAdressbook (addVars args) >>| + updateAdressbook (addVars (fromJust mt) args) >>| tell [Lab k] >>| tell [Instr "link" [Lit 0] ""] >>| //add the vars