From c3079241c4d460cecf091f7082268c5f733d8aec Mon Sep 17 00:00:00 2001 From: Itamar Date: Tue, 10 Mar 2009 18:09:21 +0200 Subject: [PATCH] fixed bug in prepareStackForAbsOpt (rtemgr.c). I used ST_OLDFP() to reach the end of the current activation frame, but its wrong. The end of the current activation frame (which now can be kindly obtained by ST_FRMEND()) is not always equal to ST_OLDFP() - such is the case when we are in the middle of some application and already pushed some evaluated arguments onto the stack. yay! --- compiler.sml | 2 +- src/c/arch.h | 26 ++++--- src/c/arch.h~ | 33 +++++---- src/c/builtins.c | 10 ++- src/c/builtins.c~ | 11 ++- src/c/rtemgr.c | 36 ++++++++-- src/c/rtemgr.c~ | 171 ---------------------------------------------- src/scm/support-code.scm | 2 +- src/scm/support-code.scm~ | 2 +- src/sml/cg.sml | 5 ++ src/sml/cg.sml~ | 5 ++ 11 files changed, 96 insertions(+), 207 deletions(-) delete mode 100644 src/c/rtemgr.c~ diff --git a/compiler.sml b/compiler.sml index 1342680..3565ac1 100644 --- a/compiler.sml +++ b/compiler.sml @@ -89,7 +89,7 @@ struct fun compileSchemeFile (infile:string, outfile:string) : unit = stringToFile ( outfile, - (compile ( (fileToString "./src/scm/support-code.scm")^ + (compile ((* (fileToString "./src/scm/support-code.scm")^ *) (fileToString infile)))); end; (* of struct CodeGen *) diff --git a/src/c/arch.h b/src/c/arch.h index 59e83c6..d254795 100644 --- a/src/c/arch.h +++ b/src/c/arch.h @@ -13,16 +13,21 @@ extern int fp; void push(int x); int pop(); -/* The stack when in a user procedure: - fp -> | | - | fp | - the old fp (before this application) - | ret | - return address - | env | - points to the enviroment vector - | n | - number of arguments - | A0 | - argument 0 - | A1 | - argument 1 - | ... | - ... - | An-1 | - argument n-1 +/* The stack **WHILE IN A USER PROCEDURE**: + fp -> | | + | fp | - the old fp (before this application) + | ret | - return address + | env | - points to the enviroment vector + | n | - number of arguments + | A0 | - argument 0 + | A1 | - argument 1 + | ... | - ... + ST_FRMEND -> | An-1 | - argument n-1 + + Note: ST_FRMEND points to the end of the current actvation frame (in fact, + to the last element: An-1). Note that ST_FRMEND does not have to be + equal to [the old fp + 1] (in case we are in the middle of an + application and already pushed some arguments onto the stack). Note: sp does NOT have to be equal to fp - for example if we are in the middle of applying a procedure and already pushed some arguments @@ -35,6 +40,7 @@ int pop(); #define ST_OLDFP() (stack[fp-1]) #define ST_RET() (stack[fp-2]) #define ST_ENV() (stack[fp-3]) +#define ST_FRMEND() (fp-4-stack[fp-4]) #define RETURN() goto *pop() /* General Purpose Registers */ diff --git a/src/c/arch.h~ b/src/c/arch.h~ index c0d18c1..d254795 100644 --- a/src/c/arch.h~ +++ b/src/c/arch.h~ @@ -13,17 +13,21 @@ extern int fp; void push(int x); int pop(); -/* The stack when in a user procedure: - fp -> | | - | fp | - the old fp (before this application) - | ret | - return address - | sp | - the old sp (before entering this procedure) - | env | - points to the enviroment vector - | n | - number of arguments - | A0 | - argument 0 - | A1 | - argument 1 - | ... | - ... - | An-1 | - argument n-1 +/* The stack **WHILE IN A USER PROCEDURE**: + fp -> | | + | fp | - the old fp (before this application) + | ret | - return address + | env | - points to the enviroment vector + | n | - number of arguments + | A0 | - argument 0 + | A1 | - argument 1 + | ... | - ... + ST_FRMEND -> | An-1 | - argument n-1 + + Note: ST_FRMEND points to the end of the current actvation frame (in fact, + to the last element: An-1). Note that ST_FRMEND does not have to be + equal to [the old fp + 1] (in case we are in the middle of an + application and already pushed some arguments onto the stack). Note: sp does NOT have to be equal to fp - for example if we are in the middle of applying a procedure and already pushed some arguments @@ -31,11 +35,12 @@ int pop(); Macros for user procedures: */ -#define ST_ARG(n) (stack[fp-6-(n)]) -#define ST_ARG_COUNT() (stack[fp-5]) +#define ST_ARG(n) (stack[fp-5-(n)]) +#define ST_ARG_COUNT() (stack[fp-4]) #define ST_OLDFP() (stack[fp-1]) #define ST_RET() (stack[fp-2]) -#define ST_ENV() (stack[fp-4]) +#define ST_ENV() (stack[fp-3]) +#define ST_FRMEND() (fp-4-stack[fp-4]) #define RETURN() goto *pop() /* General Purpose Registers */ diff --git a/src/c/builtins.c b/src/c/builtins.c index ea48a48..8a7e5cd 100644 --- a/src/c/builtins.c +++ b/src/c/builtins.c @@ -182,6 +182,14 @@ Lnull: r_res = (int)makeSchemeBool( IS_SOB_NIL(r[0]) ); BI_RETURN(); +Lchar_to_integer: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("char->integer",1) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_CHAR(r[0]), "" ); + r[0] = SOB_CHAR_VALUE(r[0]); + r_res = (int)makeSchemeInt( (int)r[0] ); + BI_RETURN(); + Lstart: /* create closures for the free variables of the built-in procedures */ CREATE_BUILTIN_CLOS("car" ,&&Lcar); @@ -195,11 +203,11 @@ Lstart: CREATE_BUILTIN_CLOS("binary-add" ,&&LbinaryADD); CREATE_BUILTIN_CLOS("binary-sub" ,&&LbinarySUB); CREATE_BUILTIN_CLOS("binary-mul" ,&&LbinaryMUL); - CREATE_BUILTIN_CLOS("binary-mul" ,&&LbinaryMUL); CREATE_BUILTIN_CLOS("binary-div" ,&&LbinaryDIV); CREATE_BUILTIN_CLOS("binaryinteger" ,&&Lchar_to_integer); /* CREATE_BUILTIN_CLOS("",&&L); */ diff --git a/src/c/builtins.c~ b/src/c/builtins.c~ index 801ee2a..8a7e5cd 100644 --- a/src/c/builtins.c~ +++ b/src/c/builtins.c~ @@ -13,7 +13,6 @@ /* The stack when in a built-in precedure (there is no fp): sp -> | | | ret | - return address - | sp | - the old sp (before entering this procedure) | env | - points to the enviroment vector | n | - number of arguments | A0 | - argument 0 @@ -183,6 +182,14 @@ Lnull: r_res = (int)makeSchemeBool( IS_SOB_NIL(r[0]) ); BI_RETURN(); +Lchar_to_integer: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("char->integer",1) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS( IS_SOB_CHAR(r[0]), "" ); + r[0] = SOB_CHAR_VALUE(r[0]); + r_res = (int)makeSchemeInt( (int)r[0] ); + BI_RETURN(); + Lstart: /* create closures for the free variables of the built-in procedures */ CREATE_BUILTIN_CLOS("car" ,&&Lcar); @@ -196,11 +203,11 @@ Lstart: CREATE_BUILTIN_CLOS("binary-add" ,&&LbinaryADD); CREATE_BUILTIN_CLOS("binary-sub" ,&&LbinarySUB); CREATE_BUILTIN_CLOS("binary-mul" ,&&LbinaryMUL); - CREATE_BUILTIN_CLOS("binary-mul" ,&&LbinaryMUL); CREATE_BUILTIN_CLOS("binary-div" ,&&LbinaryDIV); CREATE_BUILTIN_CLOS("binaryinteger" ,&&Lchar_to_integer); /* CREATE_BUILTIN_CLOS("",&&L); */ diff --git a/src/c/rtemgr.c b/src/c/rtemgr.c index 1970fa6..20e2c17 100644 --- a/src/c/rtemgr.c +++ b/src/c/rtemgr.c @@ -4,6 +4,23 @@ #include "assertions.h" #include "strings.h" +void printActFrm(int p) { + unsigned int fp,ret,env,n; + unsigned int i; + + fp = stack[p-1]; + ret = stack[p-2]; + env = stack[p-3]; + n = stack[p-4]; + + fprintf( stderr, "fp=0x%x\n", fp ); + fprintf( stderr, "ret=0x%x\n", ret ); + fprintf( stderr, "env=0x%x\n", env ); + fprintf( stderr, "n=%d\n" , n ); + for (i=p-5; i>=p-5-n+1; i--) + fprintf( stderr, "a[%d]=%s\n", -i+p-5, sobToString((SchemeObject*)(stack[i])) ); +} + /* Copies the enviroment vector currenv to a new vector of size (currenv_size+1) starting from element #1. Copies the arguments from the stack to element #0 of the new vector. @@ -134,8 +151,14 @@ void prepareStackForAbsOpt(int formalParams) /* if the optional parameter was not used, initialize it to an empty list: */ - shiftStackUp( ST_OLDFP(), 1 ); /* make room for the optional param */ - stack[ ST_OLDFP() ] = (int)makeSchemeNil(); /* set it to () */ + /* make room for the optional param */ + shiftStackUp( ST_FRMEND(), 1 ); + + /* fix actual arguments number (also affects ST_FRMEND)*/ + ST_ARG_COUNT() = formalParams; + + /* set it to () */ + stack[ ST_FRMEND() ] = (int)makeSchemeNil(); } else { /* if the optional parameters were used, move them to a list @@ -148,7 +171,7 @@ void prepareStackForAbsOpt(int formalParams) /* copy optional params to a list on the heap */ opt = makeSchemeNil(); - lastOptional = ST_OLDFP(); + lastOptional = ST_FRMEND(); firstOptional = lastOptional + (optionalsUsed-1); for (i=lastOptional; i<=firstOptional; ++i) { @@ -158,10 +181,11 @@ void prepareStackForAbsOpt(int formalParams) /* override all but one optional */ shiftStackDown( firstOptional, optionalsUsed-1 ); + /* fix actual arguments number (also affects ST_FRMEND) */ + ST_ARG_COUNT() = formalParams; + /* the last parameter is a pointer to the new list */ - stack[ ST_OLDFP() ] = (int)opt; + stack[ ST_FRMEND() ] = (int)opt; } - /* fix actual arguments number */ - ST_ARG_COUNT() = formalParams; } diff --git a/src/c/rtemgr.c~ b/src/c/rtemgr.c~ deleted file mode 100644 index 7e0b28d..0000000 --- a/src/c/rtemgr.c~ +++ /dev/null @@ -1,171 +0,0 @@ -#include "rtemgr.h" -#include "scheme.h" -#include "arch.h" -#include "assertions.h" -#include "strings.h" - -/* Copies the enviroment vector currenv to a new vector of size - (currenv_size+1) starting from element #1. - Copies the arguments from the stack to element #0 of the new vector. - Returns the new env. vector. - - @param currenv: points to the current enviroment vector - @param currenv_size: size of the current enviroment vector -*/ -int** extendEnviroment(int** currenv, int currenv_size) -{ - int** newenv; /* newenv: points to the new envoriment vector */ - int ndx; /* ndx: loop index */ - - ASSERT_ALWAYS(currenv_size>=0,""); - - /* allocate new enviroment vector */ - newenv = autoMalloc( sizeof(int) * (currenv_size + 1) ); - - /* copy current enviroment to new enviroment */ - ndx = currenv_size; -Lfor1: - if (ndx<=0) goto LendFor1; - newenv[ndx] = currenv[ndx-1]; - --ndx; - goto Lfor1; -LendFor1: - /* copy arguments from stack to new enviroment vector (extend env.) */ - if (currenv_size<=0) goto LendExtend1; /* no activation frame at all */ - if (ST_ARG_COUNT()<=0) goto LendExtend1; /* no args in act. frame */ - newenv[0] = autoMalloc( sizeof(int) * ST_ARG_COUNT() ); - ndx = 0; -Lfor2: - if (ndx>=ST_ARG_COUNT()) goto LendFor2; - newenv[0][ndx] = ST_ARG(ndx); - ++ndx; - goto Lfor2; -LendFor2: -LendExtend1: - - return newenv; -} - -/* Prepares the stack for a tail-call. - Overrides the last activation frame with the current one, - fixes sp,fp -*/ -void shiftActFrmDown() -{ - int low; /* lowest address of the activation frame (included) */ - int high; /* highest address of the activation frame (included) */ - int dest_low; /* lowest address where to put the activation frame */ - - int old_fp = ST_OLDFP(); - - /* Shift activation frame down the stack */ - low = fp; - high = sp-1; - dest_low = old_fp; - - while (low <= high) { - stack[dest_low] = stack[low]; - ++dest_low; - ++low; - } - - /* Fix sp,fp */ - fp = old_fp; - sp = dest_low; -} - -/* Shifts the elements in the stack upwards. - - @param pos: index of the first element to shift - @param amount: the number of elements to shift up each element by - - Shifts up each element between `pos` and sp (inclusive) by `amount`. -*/ -void shiftStackUp(int pos, unsigned int amount) -{ - int i; - - /* shift elements upwards */ - for (i=sp-1; i>=pos; --i) { - stack[i+amount] = stack[i]; - } - - /* fix sp,fp */ - sp = sp + amount; - fp = fp + amount; -} - -/* Shifts the elements in the stack downwards. - - @param pos: index of the first element to shift - @param amount: the number of elements to shift down each element by - - Shifts down each element between `pos` and sp (inclusive) by `amount`. -*/ -void shiftStackDown(int pos, unsigned int amount) -{ - int i; - - /* shift elements downwards */ - for (i=pos; i<=sp-1; ++i) { - stack[i-amount] = stack[i]; - } - - /* fix sp,fp */ - sp = sp - amount; - fp = fp - amount; -} - -/* Prepares the stack for an application of lambda-optional. - - @param formalParams: the number of formal parameters the lambda - expects, including the optional one. - - Moves the optional parameters to a list in the heap. -*/ -void prepareStackForAbsOpt(int formalParams) -{ - int actualParams = ST_ARG_COUNT(); - int optionalsUsed = actualParams-(formalParams-1); - - ASSERT_ALWAYS( optionalsUsed>=0, "" ); - - if (optionalsUsed==0) { - /* if the optional parameter was not used, initialize it to an - empty list: */ - - shiftStackUp( ST_OLDFP(), 1 ); /* make room for the optional param */ - stack[ ST_OLDFP() ] = (int)makeSchemeNil(); /* set it to () */ - } - else { - /* if the optional parameters were used, move them to a list - on the heap: */ - - SchemeObject* opt; /* the list of optional params */ - int lastOptional; /* last opt. param. (lowest index) */ - int firstOptional; /* first opt. param. (highest index) */ - int i; - - /* copy optional params to a list on the heap */ - opt = makeSchemeNil(); - lastOptional = ST_OLDFP(); - firstOptional = lastOptional + (optionalsUsed-1); - - for (i=lastOptional; i<=firstOptional; ++i) { - opt = makeSchemePair( (SchemeObject*)(stack[i]), opt ); - } - - /* override all but one optional */ - shiftStackDown( firstOptional, optionalsUsed-1 ); - - /* the last parameter is a pointer to the new list */ - stack[ ST_OLDFP() ] = (int)opt; - } - - /* fix actual arguments number */ - ST_ARG_COUNT() = formalParams; -} - - - - diff --git a/src/scm/support-code.scm b/src/scm/support-code.scm index 847a9f2..16956dd 100644 --- a/src/scm/support-code.scm +++ b/src/scm/support-code.scm @@ -262,7 +262,7 @@ (define vector (lambda args (list->vector args))) -o(define ormap +(define ormap (lambda (f s) (and (pair? s) (or (f (car s)) diff --git a/src/scm/support-code.scm~ b/src/scm/support-code.scm~ index 847a9f2..16956dd 100644 --- a/src/scm/support-code.scm~ +++ b/src/scm/support-code.scm~ @@ -262,7 +262,7 @@ (define vector (lambda args (list->vector args))) -o(define ormap +(define ormap (lambda (f s) (and (pair? s) (or (f (car s)) diff --git a/src/sml/cg.sml b/src/sml/cg.sml index 0b1d9b3..d3892a7 100644 --- a/src/sml/cg.sml +++ b/src/sml/cg.sml @@ -419,6 +419,11 @@ end = struct ;CSadd (CodeSegment.Statement ("shiftActFrmDown()")) (* goto proc.code *) ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))") + (* restore sp - discard: + - enviroment pointer (at sp-1) + - n, the number of arguments (at sp-2) + - n arguments *) + ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) ) ) | genExpr (Seq []) absDepth = () diff --git a/src/sml/cg.sml~ b/src/sml/cg.sml~ index db5d1c6..e191d5e 100644 --- a/src/sml/cg.sml~ +++ b/src/sml/cg.sml~ @@ -419,6 +419,11 @@ end = struct ;CSadd (CodeSegment.Statement ("shiftActFrmDown()")) (* goto proc.code *) ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))") + (* restore sp - discard: + - enviroment pointer (at sp-1) + - n, the number of arguments (at sp-2) + - n arguments *) + ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) ) ) | genExpr (Seq []) absDepth = () -- 2.11.4.GIT