diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 15 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 3 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 83 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 41 | ||||
| -rw-r--r-- | src/interp/sys-macros.lisp | 65 |
5 files changed, 72 insertions, 135 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 0dc7f2d2..4d69ae27 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,20 @@ 2009-07-04 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/c-util.boot ($middleEndMacroList): Remove COLLECTV. + * interp/compiler.boot: Don't register compiler for COLLECTV forms. + (compReduce1): Don't test for COLLECTV. + (localReferenceIfThere): New. + (compRepeatOrCollect): Use it. Tidy. + (compCollectV): Remove. + (compIteratorV): Likewise. + (computeMaxIndex): Likewise. + (exprDifference): Likewise. + * interp/g-opt.boot (optCollectVector): New. Register as + back end tranformer. + * interp/sys-macros.lisp (COLLECTV): Remove. + +2009-07-04 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/c-util.boot (simplifySEQ): New. (transformToBackendCode): Use it. diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index c7cdd14f..945ac812 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -988,8 +988,7 @@ mutateLETFormWithUnaryFunction(form,fun) == -- NOTE: It is potentially dangerous to assume every occurrence of -- element of $middleEndMacroList is actually a macro call $middleEndMacroList == - '(COLLECT REPEAT SUCHTHATCLAUSE THETA COLLECTV - THETA1 SPADREDUCE SPADDO) + '(COLLECT REPEAT SUCHTHATCLAUSE THETA THETA1 SPADREDUCE SPADDO) middleEndExpand: %Form -> %Form middleEndExpand x == diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 99bbac79..f5b1e292 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -2217,8 +2217,7 @@ compReduce(form,m,e) == compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == [collectOp,:itl,body]:= collectForm if STRINGP op then op:= INTERN op - not MEMQ(collectOp,'(COLLECT COLLECTV)) => - systemError ['"illegal reduction form:",form] + collectOp ^= "COLLECT" => systemError ['"illegal reduction form:",form] $sideEffectsList: local := nil $until: local := nil $initList: local := nil @@ -2262,7 +2261,14 @@ numberize x == x=$One => 1 atom x => x [numberize first x,:numberize rest x] - + +++ If there is a local reference to mode `m', return it. Otherwise +++ return `m' itself. +localReferenceIfThere m == + m = "$" => m + idx := NRTassocIndex m => ["getShellEntry","$",idx] + m + compRepeatOrCollect(form,m,e) == fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList ,e) where @@ -2280,10 +2286,10 @@ compRepeatOrCollect(form,m,e) == targetMode = $EmptyMode => (aggr:=["List",$EmptyMode]; $EmptyMode) [aggr,u] := modeIsAggregateOf('List,targetMode,e) => u [aggr,u] := modeIsAggregateOf('PrimitiveArray,targetMode,e) => - repeatOrCollect := "COLLECTV" + repeatOrCollect := "%CollectV" u [aggr,u] := modeIsAggregateOf('Vector,targetMode,e) => - repeatOrCollect := "COLLECTV" + repeatOrCollect := "%CollectV" u stackMessage('"Invalid collect bodytype") return nil @@ -2295,7 +2301,10 @@ compRepeatOrCollect(form,m,e) == if $until then [untilCode,.,e']:= comp($until,$Boolean,e') itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] + form':= + repeatOrCollect = "%CollectV" => + ["%CollectV",localReferenceIfThere m',:itl',body'] + [repeatOrCollect,:itl',body'] m'' := aggr is [c,.] and MEMQ(c,'(List PrimitiveArray Vector)) => [c,m'] m' @@ -2412,67 +2421,6 @@ modeIsAggregateOf(agg,m,e) == RepIfRepHack m get(name,"value",e) is [[ =agg,R],:.] => [m,R] ---% VECTOR ITERATORS - ---the following 4 functions are not currently used - -compCollectV(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where - fn(form,$exitModeStack,$leaveLevelStack,e) == - [repeatOrCollect,it,body]:= form - [it',e]:= compIteratorV(it,e) or return nil - m:= first $exitModeStack - [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode - [body',m',e']:= compOrCroak(body,mUnder,e) or return nil - form':= ["COLLECTV",it',body'] - n:= - it' is ["STEP",.,s,i,f] or it' is ["ISTEP",.,s,i,f] => - computeMaxIndex(s,f,i); - return nil - coerce([form',mOver,e'],m) - -compIteratorV(it,e) == - it is ["STEP",index,start,inc,final] => - (start':= comp(start,$Integer,e)) and - (inc':= comp(inc,$NonNegativeInteger,start'.env)) and - (final':= comp(final,$Integer,inc'.env)) => - indexmode:= - comp(start,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration(index,indexmode,final'.env) or - return nil - e:= put(index,"value",[genSomeVariable(),indexmode,$noEnv],e) - [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e] - [start,.,e]:= - comp(start,$Integer,e) or return - stackMessage('"start value of index: %1b is not an integer",[start]) - [inc,.,e]:= - comp(inc,$NonNegativeInteger,e) or return - stackMessage('"index increment: %1b must be a non-negative integer", - [inc]) - [final,.,e]:= - comp(final,$Integer,e) or return - stackMessage('"final value of index: %1b is not an integer",[final]) - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration(index,indexmode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,$noEnv],e) - [["STEP",index,start,inc,final],e] - nil - -computeMaxIndex(s,f,i) == - i^=1 => cannotDo() - s=1 => f - exprDifference(f,exprDifference(s,1)) - -exprDifference(x,y) == - y=0 => x - FIXP x and FIXP y => DIFFERENCE(x,y) - ["DIFFERENCE",x,y] - --% rep/per morphisms @@ -2551,7 +2499,6 @@ for x in [["|", :"compSuchthat"],_ ["case", :"compCase"],_ ["CATEGORY", :"compCategory"],_ ["COLLECT", :"compRepeatOrCollect"],_ - ["COLLECTV", :"compCollectV"],_ ["CONS", :"compCons"],_ ["construct", :"compConstruct"],_ ["DEF", :"compDefine"],_ diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 0fb44255..1104d4ec 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -501,6 +501,46 @@ optLET_* form == rplac(first form,"LET") optLET form +optCollectVector form == + [.,eltType,:iters,body] := form + fromList := false -- are we drawing from a list? + vecSize := nil -- size of vector + index := nil -- loop/vector index. + for iter in iters while not fromList repeat + [op,:.] := iter + MEMQ(op,'(SUCHTHAT WHILE UNTIL)) => fromList := true + MEMQ(op,'(IN ON)) => vecSize := [["SIZE",third iter],:vecSize] + MEMQ(op,'(STEP ISTEP)) => + -- pick a loop variable that we can use as the loop index. + [.,var,lo,inc,:etc] := iter + if lo = 0 and inc = 1 then + index := var + if [hi] := etc then + sz := + inc = 1 => + lo = 1 => hi + lo = 0 => MKQSADD1 hi + MKQSADD1 ["-",hi,lo] + lo = 1 => ["/",hi,inc] + lo = 0 => ["/",MKQSADD1 hi,inc] + ["/",["-",MKQSADD1 hi, lo],inc] + vecSize := [sz, :vecSize] + -- if we draw from a list, then just build a list and convert to vector. + fromList => ["LIST2VEC",["COLLECT",:iters,body]] + vecSize = nil => systemErrorHere ["optCollectVector",form] + -- get the actual size of the vector. + vecSize := + vecSize is [hi] => hi + ["MIN",:nreverse vecSize] + -- if no suitable loop index was found, introduce one. + if index = nil then + index := GENSYM() + iters := [:iters,["ISTEP",index,0,1]] + vec := GENSYM() + ["LET",[[vec,["GETREFV",vecSize]]], + ["REPEAT",:iters,["setSimpleArrayEntry",vec,index,body]], + vec] + lispize x == first optimize [x] --% optimizer hash table @@ -517,6 +557,7 @@ for x in '( (call optCall) _ (_| optSuchthat)_ (CATCH optCatch)_ (COND optCond)_ + (%CollectV optCollectVector)_ (mkRecord optMkRecord)_ (RECORDELT optRECORDELT)_ (SETRECORDELT optSETRECORDELT)_ diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp index b610af09..d0f934ad 100644 --- a/src/interp/sys-macros.lisp +++ b/src/interp/sys-macros.lisp @@ -1205,71 +1205,6 @@ (let ((U (REPEAT-TRAN L NIL))) (CONS 'THETA (CONS '\, (NCONC (CAR U) (LIST (CDR U))))))) -(defmacro COLLECTV (&rest L) - (PROG (CONDS BODY ANS COUNTER X Y) - ;;If we can work out how often we will go round - ;; allocate a vector first - (SETQ CONDS NIL) - (SETQ BODY (REVERSE L)) - (SETQ ANS (GENSYM)) - (SETQ COUNTER NIL) - (SETQ X (CDR BODY)) - (SETQ BODY (CAR BODY)) - LP - (COND ((NULL X) - (COND ((NULL COUNTER) - (SETQ COUNTER (GENSYM)) - (SETQ L (CONS (LIST 'ISTEP COUNTER 0 1) L)) )) - (RETURN (LIST 'PROGN - (LIST 'SPADLET - ANS - (LIST 'GETREFV - (COND ((NULL CONDS) - (fail)) - ((NULL (CDR CONDS)) - (CAR CONDS)) - ((CONS 'MIN CONDS)) ) )) - (CONS 'REPEAT - (NCONC (CDR (REVERSE L)) - (LIST (LIST '|setSimpleArrayEntry| - ANS - COUNTER - BODY)))) - ANS)) )) - (SETQ Y (CAR X)) - (SETQ X (CDR X)) - (COND ((MEMQ (CAR Y) '(SUCHTHAT WHILE UNTIL)) - (RETURN (LIST 'LIST2VEC (CONS 'COLLECT L)) )) - ((member (CAR Y) '(IN ON) :test #'eq) - (SETQ CONDS (CONS (LIST 'SIZE (CADDR Y)) CONDS)) - (GO LP)) - ((member (CAR Y) '(STEP ISTEP) :test #'eq) - (if (AND (EQL (CADDR Y) 0) - (EQL (CADDDR Y) 1)) - (SETQ COUNTER (CADR Y)) ) - (COND ((CDDDDR Y) ; there may not be a limit - (SETQ CONDS - (CONS - (COND ((EQL 1 (CADDDR Y)) - (COND ((EQL 1 (CADDR Y)) - (CAR (CDDDDR Y))) - ((EQL 0 (CADDR Y)) - (MKQSADD1 (CAR (CDDDDR Y)))) - ((MKQSADD1 `(- ,(CAR (CDDDDR Y)) - ,(CADDR Y)))))) - ((EQL 1 (CADDR Y)) - `(/ ,(CAR (CDDDDR Y)) ,(CADDR Y))) - ((EQL 0 (CADDR Y)) - `(/ ,(MKQSADD1 (CAR (CDDDDR Y))) - ,(CADDR Y))) - (`(/ (- ,(MKQSADD1 (CAR (CDDDDR Y))) - ,(CADDR Y)) - ,(CADDR Y)))) - CONDS)))) - (GO LP))) - (ERROR "Cannot handle macro expansion"))) - - ;; ;; -*- Non-Local Gotos -*- ;; |